(define-imported-class (icomparer-wrapper "IComparerWrapper" (procedure proc)) object)
;(import-methods (sort "Sort" (proc (object) void))
;		(sort-w/comparer "Sort"
;				 (proc (object (type-expression-value 'icomparer-wrapper))
;				       void)))
(import-static (sort "Array.Sort" (proc (object) void))
	       (sort-w/comparer "Array.Sort"
				(proc (object (type-expression-value 'i-comparer))
				      void)))

(define-imported-class (check-failed (procedure test) (object value)) exception)

(define-imported-class (index-out-of-range-exception) exception)

(define-imported-class (values ((array object) v)) object
  (define actual-values "values" (public) (array object)))
(define clr-type (type-expression-value 'clr-type))
(define meta-procedure (type-expression-value 'procedure))
(define-imported-class (enum "System.Enum") object)
(import-static (to-object "System.Enum.ToObject"
			  (proc (clr-type object) object))
	       (spawn "Meta.Utilities.Spawn"
		      (proc (object) object))
	       (declare-known-member "Meta.TypeLattice.DeclareKnownMember"
				     (proc (clr-type string) void))
	       (global-declare-known-member "Meta.TypeLattice.GlobalDeclareKnownMember"
				     (proc (clr-type string) void))
	       (declare-known-type "Meta.TypeLattice.DeclareKnownType"
				   (proc (clr-type ilist) void))
	       (global-declare-known-type "Meta.TypeLattice.GlobalDeclareKnownType"
				   (proc (clr-type ilist) void))
	       (edit-source "Meta.TopLevel.gui.EditSource"
			    (proc ((type-expression-value 'expression) boolean boolean)
				  void)))

(define-imported-class (mismatched-list-argument-exception (string message))
  exception)

(define-imported-class (empty-list-argument-exception (string message))
  exception)

(define (dmodulo x y) (modulo x y))
(import-operators (dmodulo "%" 2 (proc (float float) float)))

(define-imported-object create-instance "BindingFlags.DeclaredOnly | BindingFlags.Public | BindingFlags.NonPublic | BindingFlags.Instance | BindingFlags.CreateInstance"
  integer)

(define-imported-class (generic-procedure (object name)) procedure)

(define-imported-class (ienumerator
			"System.Collections.IEnumerator")
  object
  (define ie-current "Current" (public) object)
  (define (ie-move-next "MoveNext") (public virtual) boolean)
  (define (ie-reset "Reset") (public virtual) void))
(define-imported-class (ienumerable "System.Collections.IEnumerable") object
  (define (ie-get-enumerator "GetEnumerator") (public virtual) ienumerator))

(define idictionary (evaluate 'idictionary))
(let ((dictionary-lookup #f))
  (import-operators
   (dictionary-lookup index-operator
		      2
		      (proc (idictionary object-type)
			    object-type))))

(define-macro (make-list-accessor name position)
  `(define-primitive-procedure (,name list)
     ,(string-append "The "
		     (symbol->string name)
		     " element of list")
     (let ((lst (checked-arg-cast "list" list ilist)))
       ;; If we don't do this, then the vector-ref throws an argument-out-of-range-exception
       ;; which is going to be confusing to the user.
       (unless (> (count lst) ,position)
	 (throw (new index-out-of-range-exception)))
       (vector-ref lst ,position))))

(define-imported-class (text-reader "System.IO.TextReader") object)

(import-static (inspect "Inspector.Inspect" (proc (object) void))
	       (apropos "Apropos.ShowApropos" (proc (string) void))
	       (equivalent? "Utilities.Equivalent" (proc (object object) boolean))
	       (tree-equivalent? "Utilities.TreeEquivalent"
				 (proc (object object) boolean))
	       (concat2 "String.Concat" (proc (string string) string))
	       (concat3 "String.Concat" (proc (string string string) string))
	       (concat4 "String.Concat" (proc (string string string string)
					      string))
	       (concat5 "String.Concat" (proc (string string string string string)
					      string))
	       (concat* "String.Concat" (proc ((type-expression-value '(array string))) string))
	       (string=? "String.Equals" (proc (string string) boolean))

	       (inner-multiply "VectorSpace.InnerMultiply"
			    (proc (object object) object))
	       (magnitude "VectorSpace.Magnitude"
			  (proc (object) float))
	       (unit-vector "VectorSpace.UnitVector"
			    (proc (object) object))
	       (unit-vector-perpendicular "PointFVectorSpace.UnitVectorPerpendicular"
					  (proc (object) object))
	       (rotate-vector "PointFVectorSpace.RotateRadians"
			      (proc (object float) object))
	       (rotate-vector-degrees "PointFVectorSpace.RotateDegrees"
			      (proc (object float) object))

	       (search-for-type "Utilities.SearchForType"
				(proc (string) clr-type))
	       (object->integer "System.Convert.ToInt32"
				(proc (object) integer))
	       (object->byte "System.Convert.ToByte"
				(proc (object) byte))
	       (object->float "System.Convert.ToDouble"
			      (proc (object) float))
	       (object->single-float "System.Convert.ToSingle"
				     (proc (object) single-float))
	       (object->int16 "System.Convert.ToInt16"
			      (proc (object) short))
	       (write-to-string "Writer.WriteToString"
				(proc (object) string))
	       (safe-write-to-string "Writer.SafeWriteToString"
				     (proc (object integer)
					   string))
	       (write-to-listener "TopLevel.defaultReplOut.Write"
				  (proc (object) void))
	       (write-newline-to-listener "TopLevel.defaultReplOut.NewLine"
					  (proc () void))
	       (raw-write-to-listener "TopLevel.defaultReplOut.stream.Write"
				      (proc (object) void))

	       (set-trace "TopLevel.SetTrace"
			  (proc (meta-procedure) void))
	       (clear-trace "TopLevel.ClearTrace"
			  (proc (meta-procedure) void))
	       (clear-all-traces "TopLevel.ClearAllTraces"
			  (proc () void))
				    
	       (lock "Utilities.Lock"
		     (proc (object meta-procedure) object))
	       (unwind-protect "Utilities.UnwindProtect"
				(proc (meta-procedure meta-procedure)
				      object))
	       (ignore-errors "Utilities.IgnoreErrors"
			      (proc (meta-procedure)
				    object))
	       (catch "Utilities.Catch"
			     (proc (meta-procedure clr-type meta-procedure)
				   object))
	       (bind "Fluid.Bind"
		     (proc (object object) object))
	       (with-escape "Utilities.WithEscape"
			    (proc (meta-procedure) object)))

(import-static (tan "Math.Tan" (proc (float) float))

	       (asin "Math.Asin" (proc (float) float))
	       (acos "Math.Acos" (proc (float) float))
	       (atan "Math.Atan" (proc (float) float))
	       (atan2 "Math.Atan2" (proc (float float) float))

	       (sinh "Math.Sinh" (proc (float) float))
	       (cosh "Math.Cosh" (proc (float) float))
	       (tanh "Math.Tanh" (proc (float) float))

	       (round "Math.Round" (proc (float) float))
	       (floor "Math.Floor" (proc (float) float))
	       (ceiling "Math.Ceiling" (proc (float) float))
	       (exp "Math.Exp" (proc (float) float))
	       (log "Math.Log" (proc (float) float))
	       (sqrt "Math.Sqrt" (proc (float) float))
	       (power "Math.Pow" (proc (float float) float)))

;;;
;;; System stuff
;;;

(%import-object 'user-namespace-kluge
		"Namespace.UserNamespace"
		(type-expression-value 'namespace))

(%import-object 'current-source-file
		"Meta.TopLevel.CurrentSourceFile"
		string-type)

(define-initialized-module (lisp builtins)
  (define-primitive-procedure (dot (object vector1) (object vector2))
    "Returns the inner product (\"dot product\") of two vectors"
    (inner-multiply vector1 vector2))
  (import (magnitude (object vector))
	  "Returns the length of the vector")
  (import (unit-vector (object vector))
	  "Returns a vector in the same direction as vector, but with length 1")
  (import (unit-vector-perpendicular (object vector))
	  "Returns a vector perpendicular to vector and with length 1")
  (import (rotate-vector (object vector) (float angle-radians))
	  "Rotates vector counter-clockwise by angle radians")
  (import (rotate-vector-degrees (object vector) (float angle))
	  "Rotates vector counter-clockwise by angle degrees")

;  (import (eq? object object)
;	  "True when both arguments are the same object")
;  (import (string=? string string)
;	  "True when the two strings contain the same text, regardless of whether they are the same object.")


  (define-inequality <
    "True if arguments are in increasing order and no two elements are equal")
  (define-inequality <=
    "True if arguments are in increasing order")
  (define-inequality >
    "True if arguments are in decreasing order and no two elements are equal")
  (define-inequality >=
    "True if arguments are in decreasing order")

;  (import (> (float number1) (float number2))
;	  "True when number1 is greater than number2")
;  (import (< (float number1) (float number2))
;	  "True when number1 is less than number2")
;  (import (<= (float number1) (float number2))
;	  "True when number1 is less than or equal to number2")
;  (import (>= (float number1) (float number2))
;	  "True when number1 is greater than or equal to number2")


  (import (not boolean)
	  "True when argument is false and vice-versa")
  (import (type-of object)
	  "Returns the type of the argument object")
  (import (field-of clr-type (string field-name))
	  "Returns a procedure that reads the specified field from objects of the specified type")
  (import (property-of clr-type (string property-name))
	  "Returns a procedure that will read the specified property from objects of the specified type")
  (import (method-of clr-type (string method-name))
	  "Returns a procedure that will call the specified method on its first argument, passing its other arguments as parameters.")
  (import (drop (ilist list) (integer dropped-elements))
	  "List with its first few elements removed")
  (import (drop-right (ilist list) (integer dropped-elements))
	  "List with its last few elements removed")
  (import (take (ilist list) (integer element-count))
	  "The first element-count elements of list")
  (import (take-right (ilist list) (integer element-count))
	  "The last element-count elements of list")
  (import (index-of (ilist list) object)
	  "The position of object within list")
  (import (sin (float x))
	  "The sine of x")
  (import (cos (float x))
	  "The cosine of x")
  (import (tan (float x))
	  "The tangent of x")
  (import (asin (float x))
	  "The arc sine of x.  The inverse of sin.")
  (import (acos (float x))
	  "The arc cosine of x.  The inverse of cos.")

  (define-primitive-w/methods (atan y <x>)
    call-interface-procedure
    "Returns the inverse tangent of y/x.  X is optional and defaults to 1."
    (define (call1 this y)
      (atan (to-double y)))
    (define (call2 this y x)
      (atan2 (to-double y)
	     (to-double x))))


  (import (sinh (float x))
	  "The hyperbolic sine of x")
  (import (cosh (float x))
	  "The hyperbolic cosine of x")
  (import (tanh (float x))
	  "The hyperbolic tangent of x")

  (define-primitive-procedure (round (float x))
    "The nearest integer to x"
    (cast integer (round x)))
  (define-primitive-procedure (floor (float x))
    "The largest integer less than x"
    (cast integer (floor x)))
  (define-primitive-procedure (ceiling (float x))
    "The smallest integer greater than x."
    (cast integer (ceiling x)))

  (import (exp (float x))
	  "The value of the magical constant e raised to the power x.  This is the opposite of log")
  (import (log (float x))
	  "The natural logarithm of x, i.e. the power to which you'd have to raise the magic constant e in order to get x.  This is the opposite of exp")
  (import (power (float x) (float y))
	  "The value of x raised to the y'th power.")

  (import (sqrt (float x))
	  "The square root of x, i.e. the number you'd have to square to get x.")

  (define-primitive-procedure (== a b)
    "True when a and b are the same object"
    (reference-equals? a b))

  ;; Can't import this because in the macro processor it only supports floats
  (define-primitive-procedure (= a b)
    "True when a and b are the same or equivalent objects"
    (equivalent? a b))

  (define-primitive-procedure (not-= a b)
    "True when a and b are the same or equivalent objects"
    (not (equivalent? a b)))

  (define-primitive-procedure (tree-equivalent? a b)
    "True when a and b are the same object, equivalent objects, lists of equivalent objects"
    (tree-equivalent? a b))

  (define-primitive-procedure (abs x)
    "Returns the magnitude of x"
    (cond ((is? x integer)
	   (abs (cast integer x)))
	  ((is? x float)
	   (abs (cast float x)))
	  ((is? x single-float)
	   (abs (cast single-float x)))
	  (else
	   (throw (exception "Argument must be a number")))))

;; Moved to GenericArithmetic.cs
;  (define-primitive-procedure (max . numbers)
;    "Return the largest of a set of numbers."
;    (let ((m (vector-ref numbers 0)))
;      (dotimes (i (length numbers))
;	(let ((v (vector-ref numbers i)))
;	  (when (> v m)
;	    (set m v))))
;      m))

;  (define-primitive-procedure (min . numbers)
;    "Return the smallest of a set of numbers."
;    (let ((m (vector-ref numbers 0)))
;      (dotimes (i (length numbers))
;	(let ((v (vector-ref numbers i)))
;	  (when (< v m)
;	    (set m v))))
;      m))

  (define-primitive-procedure (mod (object num) (object denom))
    "Returns number modulo modulus (like the remainder)"
    (check-arg-type "number" num number)
    (check-arg-type "modulus" denom number)
    (if (and (integer? num)
	     (integer? denom))
	(let ((inum (to-int32 num))
	      (idenom (to-int32 denom)))
	  (let ((iremainder (modulo inum idenom)))
	    (if (> idenom 0)
		(if (>= iremainder 0)
		    (cast object iremainder)
		    (cast object (+ iremainder idenom)))
		(if (>= iremainder 0)
		    (cast object (+ iremainder idenom))
		    (cast object iremainder)))))
	(let ((dnum (to-double num))
	      (ddenom (to-double denom)))
	  (let ((dremainder (dmodulo dnum ddenom)))
	    (if (> ddenom 0)
		(if (>= dremainder 0)
		    (cast object dremainder)
		    (cast object (+ dremainder ddenom)))
		(if (>= dremainder 0)
		    (cast object (+ dremainder ddenom))
		    (cast object dremainder)))))))
	;(cast object (modulo (to-double number)
	;		     (to-double modulus)))))

  (define-primitive-procedure (remainder (object numerator) (object denominator))
    "Returns the remainer of numerator / denominator"
    ;; Turns out the C# modulus operator is really just remainder.
    (check-arg-type "number" numerator number)
    (check-arg-type "modulus" denominator number)
    (if (and (integer? numerator)
	     (integer? denominator))
	(cast object (modulo (to-int32 numerator)
			     (to-int32 denominator)))
	(cast object (dmodulo (to-double numerator)
			     (to-double denominator)))))
  ;(- numerator
  ;     (* (/ numerator denominator)
  ;	  denominator)))

  (define-primitive-procedure (bitwise-and . numbers)
    "Forms a number by ANDing corresponding bits from the inputs"
    (let ((result -1))
      (cond ((= (length numbers) 0)
	     result)
	    (else
	     (dotimes (i (length numbers))
	       (let ((value (vector-ref numbers i)))
		 (if (or (integer? value)
			 (is? value enum))
		     (set result (bitwise-and result
					      (to-int32 value)))
		     (throw (argument-type-exception "number"
						     value
						     (type->clr-type integer))))))
	     (let ((v0 (vector-ref numbers 0)))
	       (if (is? v0 enum)
		   (to-object (type-of v0) result)
		   result))))))

  (define-primitive-procedure (bitwise-or . numbers)
    "Forms a number by ORing corresponding bits from the inputs"
    (let ((result 0))
      (cond ((= (length numbers) 0)
	     result)
	    (else
	     (dotimes (i (length numbers))
	       (let ((value (vector-ref numbers i)))
		 (if (or (integer? value)
			 (is? value enum))
		     (set result (bitwise-or result
					     (to-int32 value)))
		     (throw (argument-type-exception "number"
						     value
						     (type->clr-type integer))))))
	     (let ((v0 (vector-ref numbers 0)))
	       (if (is? v0 enum)
		   (to-object (type-of v0) result)
		   result))))))

  (define-primitive-procedure (bitwise-not number)
    "Forms a number by inverting corresponding bits from the inputs"
    (cond ((integer? number)
	   (bitwise-not (to-int32 number)))
	  ((is? number enum)
	   (to-object (type-of number)
		      (bitwise-not (to-int32 number))))
	  (else
	   (throw (argument-type-exception "number"
					   number
					   (type->clr-type integer))))))

;  (import (bitwise-and integer integer)
;	  "Result has a 1 bit in its binary representation wherever both arguments have 1 bits in the same position")
;  (import (bitwise-or integer integer)
;	  "Result has a 1 bit in its binary representation wherever either argument has a 1 bit in the same position")
;  (import (bitwise-not integer)
;	  "Result has a 1 bit in its binary representation wherever its argument has a 0 bit")


  (define-primitive-procedure (zero? (float n))
    "True if n is zero"
    (= (to-double n) 0))
  (define-primitive-procedure (positive? (float n))
    "True if n is positive"
    (> (to-double n) 0))
  (define-primitive-procedure (negative? (float n))
    "True if n is negative"
    (< (to-double n) 0))
  (define-primitive-procedure (odd? (float n))
    "True when n is an odd integer"
    (= (modulo n 2) 1))
  (define-primitive-procedure (even? (float n))
    "True when n is an odd integer"
    (= (modulo n 2) 0))

  (define-primitive-procedure (single x)
    "Returns argument as a single-precision floating point number"
    (check-arg-type "number" x number)
    (object->single-float x))
  (define-primitive-procedure (double x)
    "Returns argument as a single-precision floating point number"
    (check-arg-type "number" x number)
    (object->float x))
  (define-primitive-procedure (int x)
    "Returns argument as a single-precision floating point number"
    (check-arg-type "number" x number)
    (object->integer x))
  (define-primitive-procedure (byte x)
    "Returns argument as a single-precision floating point number"
    (check-arg-type "number" x number)
    (object->byte x))

  (define-primitive-procedure (id x)
    "'Identity function': returns its argument unchanged"
    x)

  ;; Reflection
  (define-primitive-procedure (is? ob type)
    "True when object has the specified type"
    (check-arg-type "type" type clr-type)
    (let ((t (cast clr-type (the object type))))
      (is-instance-of-type t ob)))

  (define-primitive-procedure (import! . namespaces)
    ;; Import namespaces "backwards" so that the earlier ones will
    ;; have precedence over the later ones.
    (let ((i (- (length namespaces)
		1)))
      (while (>= i 0)
	(let ((n (vector-ref namespaces i)))
	  (import! default-namespace-kluge
		   (checked-arg-cast "namespace" n namespace-base)))
	(set i (- i 1))))
    default-namespace-kluge)

  (define-primitive-procedure (export! . variable-names)
    (do-array (n variable-names)
	      (export! default-namespace-kluge
		       (checked-arg-cast "variable-name" n symbol)))
    default-namespace-kluge)

  (define-primitive-procedure (namespace! (namespace ns))
    "Change current namespace to ns."
    (set-namespace! ns)
    ns)

  (define-primitive-procedure (make-namespace . imports)
    "Creates a new namespace with specified imports."
    (let ((ns (new namespace null)))
      (do-array (import imports)
		(unless (is? import namespace)
		  (throw (new argument-type-exception "import"
			      import
			      (type->clr-type namespace))))
		(import! ns (cast namespace import)))
      ns))

  (define-primitive-procedure (type-named (string type-name))
    "Returns the type object with the specified name, if one exists"
    (search-for-type type-name))

  (define-primitive-procedure (apropos (string topic))
    "Display a list of variables relevant to topic."
    (apropos topic)
    null)

;  (define-primitive-procedure (new . type-and-args)
;    (arglist type args ...)
;    "Creates a new object of the specified type; other arguments depend on the type"
;    (check-arg-type "type" (vector-ref type-and-args 0) clr-type)
;    (let ((t (cast clr-type (vector-ref type-and-args 0)))
;	  (args (new-array object (- (length type-and-args) 1)))
;	  (argt (new-array clr-type (- (length type-and-args) 1))))
;      (dotimes (i (length args))
;	(let ((arg (vector-ref type-and-args (+ i 1))))
;	  (set (vector-ref args i) arg)
;	  (set (vector-ref argt i) (type-of arg))))
;      (let ((constructor (get-constructor t argt)))
;	(when (null? constructor)
;	  (throw (missing-member-exception "No constructor is available for the provided argument types")))
;	(invoke-constructor constructor args))))

  (define-primitive-procedure (new . type-and-args)
    (arglist type args ...)
    "Creates a new object of the specified type; other arguments depend on the type"
    (check-arg-type "type" (vector-ref type-and-args 0) clr-type)
    (let ((t (cast clr-type (vector-ref type-and-args 0)))
	  (args (new-array object (- (length type-and-args) 1))))
      (copy-subarray type-and-args 1 args 0 (length args))
      (invoke-member t null
		     create-instance
		     null null
		     args)))

  (define-primitive-procedure (invoke method-name obj args)
    "Calls object's method with the specified arguments"
    (check-arg-type "method name" method-name string)
    (check-arg-type "method arguments" args (array object))
    (invoke-member (type-of obj)
		   (cast string method-name)
		   (bitwise-or public invoke-method)
		   null
		   obj
		   (cast (array object) args)))
  (define-primitive-procedure (invoke-static type method-name args)
    "Call's type's method with the specified arguments"
    (check-arg-type "type" type clr-type)
    (check-arg-type "method name" method-name string)
    (check-arg-type "method arguments" args (array object))
    (invoke-member (cast clr-type type)
		   (cast string method-name)
		   (bitwise-or (bitwise-or public invoke-method)
			       static)
		   null
		   null
		   (cast (array object) args)))

  (define-primitive-procedure (field name obj)
    "Returns the specified field of the object"
    (check-arg-type "field name" name string)
    (invoke-member (type-of obj)
		   (cast string name)
		   (bitwise-or public 
			       (bitwise-or get-field get-property))
		   null
		   obj
		   null))
  (define-primitive-procedure (static-field type name)
    "Returns the specified field of the type"
    (check-arg-type "type" type clr-type)
    (check-arg-type "field name" name string)
    (invoke-member (cast clr-type type)
		   (cast string name)
		   (bitwise-or (bitwise-or public
					   (bitwise-or get-field get-property))
			       static)
		   null
		   null
		   null))

  ;; Lists (arrays really)
  (define-primitive-procedure (list . elements)
    "A list with the specified elements"
    elements)

  (define-primitive-procedure (typed-array . type-and-elements)
    "Returns an array of the specified type containing the specified elements"
    (unless (>= (length type-and-elements)
	       1)
      (wrong-number-of-args this type-and-elements))
    (check-arg-type "type"
		    (vector-ref type-and-elements 0)
		    clr-type)
    (let ((a (make-array (cast clr-type
			       (vector-ref type-and-elements 0))
			 (- (length type-and-elements)
			    1))))
      (copy-subarray type-and-elements 1
		     a 0
		     (length a))
      a))

;  (define-primitive-procedure (map . proc-and-lists)
;    "Returns a list with the values of the procedure applied to each element of the input list"
;    (arglist procedure lists ...)
;    (check-arg-type "procedure"
;		    (vector-ref proc-and-lists 0)
;		    procedure)
;    (check-arg-type "list"
;		    (vector-ref proc-and-lists 1)
;		    ilist)
;    (let ((callable (cast procedure (vector-ref proc-and-lists 0)))
;	  (len (- (length proc-and-lists) 1)))
;      ;; Make sure all args are lists.
;      (let ((seqs (new-array ilist len)))
;	(dotimes (i len)
;	  (set (vector-ref seqs i)
;	       (cast ilist
;		     (vector-ref proc-and-lists (+ i 1)))))
;	(let ((result (new-array object (count (vector-ref seqs 0)))))
;	  (dotimes (relt (length result))
;	    (dotimes (arg len)
;	      (let ((arglist (new-array object len)))
;		(set (vector-ref arglist arg)
;		     (vector-ref (vector-ref seqs arg)
;				 relt)))
;	      (set (vector-ref result relt)
;		   (traced-apply callable arglist))))
;	  result))))

  (define-primitive-w/methods (map procedure lists ...)
    apply-interface-procedure
    "Returns a list with the values of the procedure applied to each element of the input list(s)"
    (define (call2 this proc-arg list-arg)
      (let ((proc (checked-arg-cast "procedure" proc-arg procedure))
	    (stack current-thread-eval-stack))
	(if (is? list-arg ilist)
	    (let ((list (cast ilist list-arg)))
	      (let ((len (count list)))
		(let ((result (new-array object len)))
		  (dotimes (i len)
		    (set (vector-ref result i)
			 (traced-call1 proc stack (vector-ref list i))))
		  result)))
	    (let ((e (ie-get-enumerator (checked-arg-cast "list" list-arg ienumerable)))
		  (r (array-list)))
	      (while (ie-move-next e)
		(add r
		     (traced-call1 proc stack (ie-current e))))
	      r))))
    (define (call3 this proc-arg list1-arg list2-arg)
      (let ((proc (checked-arg-cast "procedure" proc-arg procedure))
	    (list1 (checked-arg-cast "list1" list1-arg ilist))
	    (list2 (checked-arg-cast "list2" list2-arg ilist))
	    (stack current-thread-eval-stack))
	(let ((len (count list1)))
	  (unless (= (count list2)
		     len)
	    (throw (mismatched-list-argument-exception "List arguments to map must have the same length")))
	  (let ((result (new-array object len)))
	    (dotimes (i len)
	      (set (vector-ref result i)
		   (traced-call2 proc stack
				 (vector-ref list1 i)
				 (vector-ref list2 i))))
	    result))))
    (define (apply this proc-and-lists)
      (unless (> (length proc-and-lists)
		 1)
	(wrong-number-of-args this proc-and-lists))
      (let ((procarg (vector-ref proc-and-lists 0)))
	(let ((callable (checked-arg-cast "procedure" procarg procedure))
	      (len (- (length proc-and-lists) 1))
	      (stack current-thread-eval-stack))
	  ;; Make sure all args are lists.
	  (let ((seqs (new-array ilist len)))
	    (dotimes (i len)
	      (let ((listarg (vector-ref proc-and-lists (+ i 1))))
		(set (vector-ref seqs i)
		     (checked-arg-cast "list" listarg ilist))))
	    (let ((llen (count (vector-ref seqs 0))))
	      (for ((lindex 1 (+ lindex 1)))
		   (< lindex len)
		   (unless (= (count (vector-ref seqs lindex))
			    llen)
		     (throw (mismatched-list-argument-exception "List arguments to map must have the same length"))))
	      (let ((result (new-array object llen)))
		(dotimes (relt llen)
		  (let ((args (new-array object len)))
		    (dotimes (arg len)
		    (set (vector-ref args arg)
			 (vector-ref (vector-ref seqs arg)
				     relt)))
		    (set (vector-ref result relt)
			 (traced-apply callable stack args))))
	      result)))))))

  (define-primitive-w/methods (for-each procedure lists ...)
    apply-interface-procedure
    "Calls the procedure on each element of the input list, in order"
    (define (call2 this proc-arg list-arg)
      (let ((proc (checked-arg-cast "procedure" proc-arg procedure))
	    (stack current-thread-eval-stack))
	(if (is? list-arg ilist)
	    (let ((list (cast ilist list-arg)))
	      (let ((len (count list)))
		(dotimes (i len)
		  (traced-call1 proc stack (vector-ref list i)))
		null))
	    (let ((e (ie-get-enumerator
		      (checked-arg-cast "list" list-arg ienumerable))))
	      (while (ie-move-next e)
		(traced-call1 proc stack (ie-current e)))
	      null))))
    (define (call3 this proc-arg list1-arg list2-arg)
      (let ((proc (checked-arg-cast "procedure" proc-arg procedure))
	    (list1 (checked-arg-cast "list1" list1-arg ilist))
	    (list2 (checked-arg-cast "list2" list2-arg ilist))
	    (stack current-thread-eval-stack))
	(let ((len (count list1)))
	  (unless (= (count list2)
		     len)
	    (throw (mismatched-list-argument-exception "List arguments to map must have the same length")))
	  (dotimes (i len)
	    (traced-call2 proc stack
			  (vector-ref list1 i)
			  (vector-ref list2 i)))
	  null)))
    (define (apply this proc-and-lists)
      (unless (> (length proc-and-lists)
		 1)
	(wrong-number-of-args this proc-and-lists))
      (let ((procarg (vector-ref proc-and-lists 0)))
	(let ((callable (checked-arg-cast "procedure" procarg procedure))
	      (len (- (length proc-and-lists) 1))
	      (stack current-thread-eval-stack))
	  ;; Make sure all args are lists.
	  (let ((seqs (new-array ilist len)))
	    (dotimes (i len)
	      (let ((listarg (vector-ref proc-and-lists (+ i 1))))
		(set (vector-ref seqs i)
		     (checked-arg-cast "list" listarg ilist))))
	    (let ((llen (count (vector-ref seqs 0))))
	      (for ((lindex 1 (+ lindex 1)))
		   (< lindex len)
		   (unless (= (count (vector-ref seqs lindex))
			      llen)
		     (throw (mismatched-list-argument-exception "List arguments to map must have the same length"))))
	      (dotimes (relt llen)
		(let ((args (new-array object len)))
		  (dotimes (arg len)
		    (set (vector-ref args arg)
			 (vector-ref (vector-ref seqs arg)
				     relt)))
		  (traced-apply callable stack args)))
	      null))))))

;  (define-primitive-procedure (for-each . proc-and-lists)
;    "Calls the procedure on each element of the input list, in order"
;    (arglist procedure lists ...)
;    (check-arg-type "procedure"
;		    (vector-ref proc-and-lists 0)
;		    procedure)
;    (check-arg-type "ilist"
;		    (vector-ref proc-and-lists 1)
;		    (array object))
;    (let ((callable (cast procedure (vector-ref proc-and-lists 0)))
;	  (len (- (length proc-and-lists) 1)))
;      ;; Make sure all args are lists.
;      (let ((seqs (new-array (array object) len))
;	    (arglist (new-array object len)))
;	(dotimes (i len)
;	  (set (vector-ref seqs i)
;	       (cast (array object)
;		     (vector-ref proc-and-lists (+ i 1)))))
;	(dotimes (elt (length (vector-ref seqs 0)))
;	  (dotimes (arg len)
;	    (set (vector-ref arglist arg)
;		 (vector-ref (vector-ref seqs arg)
;			     elt)))
;	  (traced-apply callable arglist))))
;    null)

  (define-primitive-procedure (up-to (integer count) (procedure procedure))
    "Returns the values of procedure called on numbers from 0 to count-1."
    (let ((results (new-array object count))
	  (stack current-thread-eval-stack))
      (dotimes (n count)
	(set (vector-ref results n)
	     (traced-call1 procedure stack n)))
      results))

  (define-primitive-procedure (iterated (integer count)
					initial-value
					(procedure procedure))
    "Returns the values of inital-value, (procedure initial-value), (procedure (procedure initial-value)), etc."
    (let ((results (new-array object count))
	  (value initial-value)
	  (stack current-thread-eval-stack))
      (set (vector-ref results 0) initial-value)
      (for ((n 1 (+ n 1)))
	   (< n count)
	   (set value
		(traced-call1 procedure stack value))
	   (set (vector-ref results n) value))
      results))

  (define-primitive-procedure (repeat (procedure procedure)
				      initial-value
				      (integer count))
    "Returns the values of inital-value, (procedure initial-value), (procedure (procedure initial-value)), etc."
    (let ((value initial-value)
	  (stack current-thread-eval-stack))
      (for ((n 0 (+ n 1)))
	   (< n count)
	   (set value
		(traced-call1 procedure stack value)))
      value))


  (define-primitive-procedure (length list)
    "The number of elements in the list"
    (count (checked-arg-cast "list" list ilist)))

  (define-primitive-procedure (item list index)
    "The index'th element of list"
    (check-arg-type "index" index integer)
    (vector-ref (checked-arg-cast "list" list ilist)
		(cast integer index)))

  (define-primitive-procedure (set-item (ilist list) (integer index) value)
    "Sets the index'th element of list to value"
    (set (vector-ref list index)
	 value)
    value)

  (define-primitive-procedure (lookup (idictionary dictionary)
				      (object key))
    "Returns the entry in dictionary for key, or null, if there is none."
    (dictionary-lookup dictionary key))

  (define-primitive-procedure (store-dictionary (idictionary dictionary)
						(object key)
						value)
    "Sets the entry in dictionary for key, or null, if there is none to value."
    (set (dictionary-lookup dictionary key) value)
    value)

  (make-list-accessor first 0)
  (make-list-accessor second 1)
  (make-list-accessor third 2)
  (make-list-accessor fourth 3)
  (make-list-accessor fifth 4)
  (make-list-accessor sixth 5)
  (make-list-accessor seventh 6)
  (make-list-accessor eighth 7)
  (make-list-accessor ninth 8)
  (make-list-accessor tenth 9)

  (define-primitive-procedure (rest list)
    "Returns all but the first element of list (slow)"
    (rest (checked-arg-cast "list" list ilist)))

;    (let ((il (cast ilist list)))
;      (sublist il
;	       1
;	       (- (count il) 1))))


  (import (empty? (ilist list))
	  "True if the list has no elements")
  (import (cons object (ilist list))
	  "Returns a list with object followed by all the elements of list")

  (define-primitive-w/methods (make-list length <element-value>)
    call-interface-procedure
    "Make a new list (array) of the specified length, optionally with all elements set to element-value"
    (define (call1 proc length)
      (check-arg-type "length" length integer)
      (new-array object (object->integer length)))
    (define (call2 proc length fill)
      (check-arg-type "length" length integer)
      (let ((l (object->integer length)))
	(let ((a (new-array object l)))
	  (dotimes (i l)
	    (set (vector-ref a i) fill))
	  a))))

  (define-primitive-w/methods (arithmetic-series count <start> <step>)
    call-interface-procedure
    "Returns a list of count elements, starting from start, counting up by step"
    (define (call1 proc count)
      (check-arg-type "count" count integer)
      (let ((c (object->integer count)))
	(let ((a (new-array integer c)))
	  (dotimes (i c)
	    (set (vector-ref a i) i))
	  a)))
    (define (call2 proc count start)
      (check-arg-type "count" count integer)
      (check-arg-type "start" start number)
      (let ((c (object->integer count)))
	(if (integer? start)
	    (let ((a (new-array integer c))
		  (s (object->integer start)))
	      (dotimes (i c)
		(set (vector-ref a i) (+ i s)))
	      a)
	    (let ((a (new-array float c))
		  (s (object->float start)))
	      (dotimes (i c)
		(set (vector-ref a i) (+ i s)))
	      a))))
    (define (call3 proc count start step)
      (check-arg-type "count" count integer)
      (check-arg-type "start" start number)
      (check-arg-type "step" start number)
      (let ((c (object->integer count)))
	(if (and (integer? start)
		 (integer? step))
	    (let ((a (new-array integer c))
		  (s (object->integer start))
		  (st (object->integer step)))
	      (dotimes (i c)
		(set (vector-ref a i) s)
		(set s (+ s st)))
	      a)
	    (let ((a (new-array float c))
		  (s (object->float start))
		  (st (object->float step)))
	      (dotimes (i c)
		(set (vector-ref a i) s)
		(set s (+ s st)))
	      a)))))

  (define-primitive-procedure (split-at (ilist list) (integer position))
    "Returns two lists, the first -position- elements and the rest"
    (values (new-array object 2
		       (sublist list 0 position)
		       (sublist list position
				(- (count list) position)))))

  (define-primitive-procedure (last (ilist list))
    "Returns the last element of list"
    (vector-ref list
		(- (count list) 1)))

  (define-primitive-procedure (reverse (ilist list))
    "Returns a new list with the elements of list in reverse order"
    (let ((c (count list)))
      (let ((a (new-array object c)))
	(dotimes (i c)
	  (set (vector-ref a i)
	       (vector-ref list (- (- c 1) i))))
	a)))

  (define-primitive-procedure (reverse! (ilist list))
    "Reverses the elements of list in place"
    (let ((c (count list)))
      (dotimes (i (quotient c 2))
	(let ((temp (vector-ref list i)))
	  (set (vector-ref list i)
	       (vector-ref list (- (- c 1) i)))
	  (set (vector-ref list (- (- c 1) i))
	       temp)))
      list))

  (define-primitive-w/methods (zip lists ...)
    call-interface-procedure
    "Returns a list consisting of sublists with the first elements of each list, the the second, etc."
    (define (call1 proc list1)
      (let ((l1 (checked-arg-cast "list1" list1 ilist)))
	(let ((result (new-array object (count l1))))
	  (dotimes (i (length result))
	    (set (vector-ref result i)
		 (new-array object 1
			    (vector-ref l1 i))))
	  result)))
    (define (call2 proc list1 list2)
      (let ((l1 (checked-arg-cast "list1" list1 ilist))
	    (l2 (checked-arg-cast "list2" list2 ilist)))
	(let ((result (new-array object (count l1))))
	  (dotimes (i (length result))
	    (set (vector-ref result i)
		 (new-array object 2
			    (vector-ref l1 i)
			    (vector-ref l2 i))))
	  result)))
    (define (call3 proc list1 list2 list3)
      (let ((l1 (checked-arg-cast "list1" list1 ilist))
	    (l2 (checked-arg-cast "list2" list2 ilist))
	    (l3 (checked-arg-cast "list3" list3 ilist)))
	(let ((result (new-array object (count l1))))
	  (dotimes (i (length result))
	    (set (vector-ref result i)
		 (new-array object 3
			    (vector-ref l1 i)
			    (vector-ref l2 i)
			    (vector-ref l3 i))))
	  result)))
    (define (call4 proc list1 list2 list3 list4)
      (let ((l1 (checked-arg-cast "list1" list1 ilist))
	    (l2 (checked-arg-cast "list2" list2 ilist))
	    (l3 (checked-arg-cast "list3" list3 ilist))
	    (l4 (checked-arg-cast "list4" list4 ilist)))
	(let ((result (new-array object (count l1))))
	  (dotimes (i (length result))
	    (set (vector-ref result i)
		 (new-array object 4
			    (vector-ref l1 i)
			    (vector-ref l2 i)
			    (vector-ref l3 i)
			    (vector-ref l4 i))))
	  result)))
    (define (call5 proc list1 list2 list3 list4 list5)
      (let ((l1 (checked-arg-cast "list1" list1 ilist))
	    (l2 (checked-arg-cast "list2" list2 ilist))
	    (l3 (checked-arg-cast "list3" list3 ilist))
	    (l4 (checked-arg-cast "list4" list4 ilist))
	    (l5 (checked-arg-cast "list5" list5 ilist)))
	(let ((result (new-array object (count l1))))
	  (dotimes (i (length result))
	    (set (vector-ref result i)
		 (new-array object 5
			    (vector-ref l1 i)
			    (vector-ref l2 i)
			    (vector-ref l3 i)
			    (vector-ref l4 i)
			    (vector-ref l5 i))))
	  result)))
    (define (call6 proc list1 list2 list3 list4 list5 list6)
      (let ((l1 (checked-arg-cast "list1" list1 ilist))
	    (l2 (checked-arg-cast "list2" list2 ilist))
	    (l3 (checked-arg-cast "list3" list3 ilist))
	    (l4 (checked-arg-cast "list4" list4 ilist))
	    (l5 (checked-arg-cast "list5" list5 ilist))
	    (l6 (checked-arg-cast "list6" list6 ilist)))
	(let ((result (new-array object (count l1))))
	  (dotimes (i (length result))
	    (set (vector-ref result i)
		 (new-array object 6
			    (vector-ref l1 i)
			    (vector-ref l2 i)
			    (vector-ref l3 i)
			    (vector-ref l4 i)
			    (vector-ref l5 i)
			    (vector-ref l6 i))))
	  result))))

  (define-primitive-procedure (unzip1 (ilist list-of-lists))
    "Returns a list of the first elements of each element of list-of-lists"
    (let ((c (count list-of-lists)))
      (let ((result (new-array object c)))
	(dotimes (i c)
	  (let ((l (as (vector-ref list-of-lists i)
		       ilist)))
	    (when (null? l)
	      (throw (argument-type-exception "sublist"
					      (vector-ref list-of-lists i)
					      (type->clr-type ilist))))
	    (set (vector-ref result i)
		 (vector-ref l 0))))
	result)))

  (define-primitive-procedure (unzip2 (ilist list-of-lists))
    "Returns a list of the first elements of each element of list-of-lists"
    (let ((c (count list-of-lists)))
      (let ((result0 (new-array object c))
	    (result1 (new-array object c)))
	(dotimes (i c)
	  (let ((l (as (vector-ref list-of-lists i)
		       ilist)))
	    (when (null? l)
	      (throw (argument-type-exception "sublist"
					      (vector-ref list-of-lists i)
					      (type->clr-type ilist))))
	    (set (vector-ref result0 i)
		 (vector-ref l 0))
	    (set (vector-ref result1 i)
		 (vector-ref l 1))))
	(values (new-array object 2 result0 result1)))))

  (define-primitive-procedure (unzip3 (ilist list-of-lists))
    "Returns a list of the first elements of each element of list-of-lists"
    (let ((c (count list-of-lists)))
      (let ((result0 (new-array object c))
	    (result1 (new-array object c))
	    (result2 (new-array object c)))
	(dotimes (i c)
	  (let ((l (as (vector-ref list-of-lists i)
		       ilist)))
	    (when (null? l)
	      (throw (argument-type-exception "sublist"
					      (vector-ref list-of-lists i)
					      (type->clr-type ilist))))
	    (set (vector-ref result0 i)
		 (vector-ref l 0))
	    (set (vector-ref result1 i)
		 (vector-ref l 1))
	    (set (vector-ref result2 i)
		 (vector-ref l 2))))
	(values (new-array object 3 result0 result1 result2)))))

  (define-primitive-procedure (unzip4 (ilist list-of-lists))
    "Returns a list of the first elements of each element of list-of-lists"
    (let ((c (count list-of-lists)))
      (let ((result0 (new-array object c))
	    (result1 (new-array object c))
	    (result2 (new-array object c))
	    (result3 (new-array object c)))
	(dotimes (i c)
	  (let ((l (as (vector-ref list-of-lists i)
		       ilist)))
	    (when (null? l)
	      (throw (argument-type-exception "sublist"
					      (vector-ref list-of-lists i)
					      (type->clr-type ilist))))
	    (set (vector-ref result0 i)
		 (vector-ref l 0))
	    (set (vector-ref result1 i)
		 (vector-ref l 1))
	    (set (vector-ref result2 i)
		 (vector-ref l 2))
	    (set (vector-ref result3 i)
		 (vector-ref l 3))))
	(values (new-array object 4 result0 result1 result2 result3)))))

  (define-primitive-procedure (unzip5 (ilist list-of-lists))
    "Returns a list of the first elements of each element of list-of-lists"
    (let ((c (count list-of-lists)))
      (let ((result0 (new-array object c))
	    (result1 (new-array object c))
	    (result2 (new-array object c))
	    (result3 (new-array object c))
	    (result4 (new-array object c)))
	(dotimes (i c)
	  (let ((l (as (vector-ref list-of-lists i)
		       ilist)))
	    (when (null? l)
	      (throw (argument-type-exception "sublist"
					      (vector-ref list-of-lists i)
					      (type->clr-type ilist))))
	    (set (vector-ref result0 i)
		 (vector-ref l 0))
	    (set (vector-ref result1 i)
		 (vector-ref l 1))
	    (set (vector-ref result2 i)
		 (vector-ref l 2))
	    (set (vector-ref result3 i)
		 (vector-ref l 3))
	    (set (vector-ref result4 i)
		 (vector-ref l 4))))
	(values (new-array object 5 result0 result1 result2 result3 result4)))))

  (define-primitive-procedure (partition (procedure predicate) (ilist list))
    "Returns two lists, the first contains all elements of list that satisfy predicate, the other the remaining elements"
    (let ((yes (array-list))
	  (no (array-list))
	  (estack current-thread-eval-stack))
      (dotimes (i (count list))
	(let ((elt (vector-ref list i)))
	  (let ((test (checked-test-cast "Predicate must return a Boolean (true or false)"
					 (traced-call1 predicate estack elt))))
	    (if test
		(add yes elt)
		(add no elt)))))
      (values (new-array object 2 yes no))))

  (define-primitive-procedure (remove (procedure predicate) (ilist list))
    "Returns list without the elements satisfying predicate"
    (let ((no (array-list))
	  (estack current-thread-eval-stack))
      (dotimes (i (count list))
	(let ((elt (vector-ref list i)))
	  (let ((test (checked-test-cast"Predicate must return a Boolean (i.e. true or false)"
					(traced-call1 predicate estack elt))))
	  (unless test
	    (add no elt)))))
      no))

  (define-primitive-w/methods (delete item list <=>)
    call-interface-procedure
    "Remove all copies of item from list, using = as a comparison predicate"
    (define (call2 proc item list)
      (let ((l (checked-arg-cast "list" list ilist))
	    (result (array-list)))
	(dotimes (i (count l))
	  (let ((e (vector-ref l i)))
	    (unless (equivalent? e item)
	      (add result e))))
	result))
    (define (call2 proc item list pred)
      (let ((l (checked-arg-cast "list" list ilist))
	    (p (checked-arg-cast "predicate" pred procedure))
	    (result (array-list)))
	(cond ((is? p primitive-procedure-=)
	       (dotimes (i (count l))
		 (let ((e (vector-ref l i)))
		   (unless (equivalent? e item)
		     (add result e)))))
	      ((is? p primitive-procedure-tree-equivalent?)
	       (dotimes (j (count l))
		 (let ((e (vector-ref l j)))
		   (unless (tree-equivalent? e item)
		     (add result e)))))
	      ((is? p primitive-procedure-==)
	       (dotimes (k (count l))
		 (let ((e (vector-ref l k)))
		   (unless (eq? e item)
		     (add result e)))))
	      (else
	       (let ((estack current-thread-eval-stack))
		 (dotimes (i (count l))
		   (let ((e (vector-ref l i))
			 (test (traced-call2 p estack e item)))
		     (unless (is? test boolean)
		       (throw (type-exception "Predicate returned a non-boolean value"
					      test
					      (type->clr-type boolean))))
		     (unless (cast boolean test)
		       (add result e)))))))
	result)))

  (define-primitive-procedure (delete-duplicates (ilist list))
    "Returns a new list contains the items if list, in order, w/o duplicates"
    (let ((result (array-list)))
      (dotimes (i (count list))
	(let ((e (vector-ref list i))
	      (found? false)
	      (j 0))
	  (while (and (< j (count result))
		      (not found?))
	    (when (equivalent? e (vector-ref result j))
	      (set found? #t))
	    (set j (+ j 1)))
	  (unless found?
	    (add result e))))
      result))

  (define-primitive-w/methods (sort list <comparer>)
    call-interface-procedure
    "Returns a sorted copy of list, optionally using comparer"
    (define (call1 this list)
      (let ((inl (checked-arg-cast "list" list ilist)))
	(let ((outl (new-array object (count inl))))
	  (copy-to inl outl 0)
	  (sort outl)
	  outl)))
    (define (call2 this list proc)
      (let ((inl (checked-arg-cast "list" list ilist))
	    (comparer (checked-arg-cast "compare-proc" proc i-comparer)))
		; (icomparer-wrapper (checked-arg-cast "comparer"
		;					   proc procedure))))
	(let ((outl (new-array object (count inl))))
	  (copy-to inl outl 0)
	  (sort-w/comparer outl comparer)
	  outl))))

  (define-primitive-procedure (append . lists)
    "A new list formed by joining the argument lists"
    (let ((total-length 0))
      (dotimes (i (length lists))
	(let ((larg (vector-ref lists i)))
	  (set total-length
	       (+ total-length (count (checked-arg-cast "list" larg ilist))))))
      (let ((result (new-array object total-length))
	    (position 0))
	(dotimes (j (length lists))
	  (let ((a (cast ilist
			 (vector-ref lists j))))
	    (copy-to a result position)
	    (set position (+ position (count a)))))
	result)))

  (define-primitive-procedure (concat . strings)
    "Return a new string formed by appending the argument strings"
    (let ((string-array (new-array string (length strings))))
      (copy-to strings string-array 0)
      (concat* string-array)))

  (define-primitive-procedure (sublist list start len)
    "Returns a specified chunk of the input list"
    (check-arg-type "starting element" start integer)
    (check-arg-type "length" len integer)
    (let ((ilen (cast integer len))
	  (istart (cast integer start)))
      (let ((result (new-array object ilen))
	    (arr (checked-arg-cast "list" list ilist)))
	(dotimes (i ilen)
	  (set (vector-ref result i)
	       (vector-ref arr (+ istart i))))
	result)))

  (define-primitive-w/methods (fold procedure <start-value> list)
    call-interface-procedure
    "Calls op on each element of list, accumulating the results as it goes, e.g. [fold + 0 seq] will give the sum of the elements of seq"
    (define (call2 this proc lst)
      (let ((op (checked-arg-cast "procedure" proc procedure))
	    (stack current-thread-eval-stack))
	(if (is? lst ilist)
	    (let ((list (cast ilist lst)))
	      (unless (> (count list)
			 0)
		(throw (empty-list-argument-exception "List argument must have at least one element when no start value is specified")))
	      (let ((total (vector-ref list 0)))
		(for ((i 1 (+ i 1)))
		     (< i (count list))
		     (let ((elt (vector-ref list i)))
		       (set total
			    (traced-call2 op stack elt total))))
		total))
	    (let ((e (ie-get-enumerator (checked-arg-cast "list" lst ienumerable)))
		  (t null))
	      (ie-move-next e)
	      (set t (ie-current e))
	      (while (ie-move-next e)
		(set t
		     (traced-call2 op stack
				   (ie-current e)
				   t)))
	      t))))
    (define (call3 this proc start lst)
      (let ((total start)
	    (op (checked-arg-cast "procedure" proc procedure))
	    (stack current-thread-eval-stack))
	(if (is? lst ilist)
	    (let ((list (cast ilist lst)))
	      (dotimes (i (count list))
		(let ((elt (vector-ref list i)))
		  (set total
		       (traced-call2 op stack elt total))))
	      total)
	    (let ((e (ie-get-enumerator (checked-arg-cast "list" lst ienumerable))))
	      (ie-move-next e)
	      (set total (ie-current e))
	      (while (ie-move-next e)
		(set total
		     (traced-call2 op stack
				   (ie-current e)
				   total)))
	      total)))))

  (define-primitive-w/methods (fold-right procedure <start-value> list)
    call-interface-procedure
    "Calls op on each element of list, starting from the end, accumulating the results as it goes, e.g. [fold-right + 0 seq] will give the sum of the elements of seq"
    (define (call2 this proc lst)
      (let ((op (checked-arg-cast "procedure" proc procedure))
	    (stack current-thread-eval-stack))
	(if (is? lst ilist)
	    (let ((list (cast ilist lst)))
	      (unless (> (count list)
			 0)
		(throw (empty-list-argument-exception "List argument must have at least one element when no start value is specified")))
	      (let ((end (- (count list) 1)))
		(let ((total (vector-ref list end)))
		  (for ((i 1 (+ i 1)))
		       (< i (count list))
		       (let ((elt (vector-ref list (- end i))))
			 (set total
			      (traced-call2 op stack elt total))))
		  total)))
	    (let ((e (ie-get-enumerator (checked-arg-cast "list" lst ienumerable)))
		  (t null))
	      (ie-move-next e)
	      (set t (ie-current e))
	      (while (ie-move-next e)
		(set t
		     (traced-call2 op stack
				   (ie-current e)
				   t)))
	      t))))
    (define (call3 this proc start lst)
      (let ((total start)
	    (op (checked-arg-cast "procedure" proc procedure))
	    (stack current-thread-eval-stack))
	(if (is? lst ilist)
	    (let ((list (cast ilist lst)))
	      (let ((end (- (count list) 1)))
		(dotimes (i (count list))
		  (let ((elt (vector-ref list (- end i))))
		    (set total
			 (traced-call2 op stack elt total))))
		total))
	    (let ((e (ie-get-enumerator (checked-arg-cast "list" lst ienumerable))))
	      (ie-move-next e)
	      (set total (ie-current e))
	      (while (ie-move-next e)
		(set total
		     (traced-call2 op stack
				   (ie-current e)
				   total)))
	      total)))))

  (define-primitive-procedure (filter test-procedure list)
    "Returns a list of just those elements of list for which test-procedure returns true"
    (let ((callable (checked-arg-cast "test-prcedure" test-procedure procedure))
	  (result (array-list))
	  (stack current-thread-eval-stack))
      (if (is? list ilist)
	  (let ((arr (cast ilist list)))
	    (dotimes (i (count arr))
	      (let ((test (checked-test-cast "Result of test-procedure must be a Boolean (i.e. true or false)"
					     (traced-call1 callable stack
							   (vector-ref arr i)))))
	      (when test
		(add result
		     (vector-ref arr i)))))
	    result)
	  (let ((e (ie-get-enumerator (checked-arg-cast "list" list ienumerable))))
	    (while (ie-move-next e)
	      (let ((test2 (checked-test-cast "Result of test-procedure must be a Boolean (i.e. true or false)"
					      (traced-call1 callable stack
							    (ie-current e)))))
		(when test2
		  (add result (ie-current e)))))
	    result))))

  (define-primitive-procedure (find test-procedure list)
    "Returns the first element of list for which test-procedure returns true, else null."
    (let ((pred (checked-arg-cast "predicate" test-procedure procedure))
	  (stack current-thread-eval-stack))
      (if (is? list ilist)
	  (let ((seq (cast ilist list)))
	    (dotimes (i (count seq))
	      (let ((item (vector-ref seq i)))
		(let ((test (checked-test-cast "Result of the test procedure must be a Boolean (i.e. true or false)"
					       (traced-call1 pred stack item))))
		  (when test
		    (return item)))))
	    null)
	  (let ((e (ie-get-enumerator (checked-arg-cast "list" list ienumerable))))
	    (while (ie-move-next e)
	      (let ((test2 (checked-test-cast "Result of the test procedure must be a Boolean (i.e. true or false)"
					      (traced-call1 pred stack (ie-current e)))))
		(when test2
		  (return (ie-current e)))))
	    null))))

  (define-primitive-procedure (list-index test-procedure list)
    "Returns the first element of list for which test-procedure is true, else null."
    (let ((pred (checked-arg-cast "test-procedure" test-procedure procedure))
	  (seq (checked-arg-cast "list" list ilist))
	  (stack current-thread-eval-stack))
      (dotimes (i (count seq))
	(let ((item (vector-ref seq i)))
	  (let ((test (checked-test-cast "The result of the test procedure must be a Boolean (i.e. true or false)"
					 (traced-call1 pred stack item))))
	    (when test
	      (return i)))))
      null))

;  (define-primitive-procedure (any test-procedure list)
;    "True if test-procedure returns true for some element of list."
;    (let ((pred (checked-arg-cast "test-procedure" test-procedure procedure))
;	  (stack current-thread-eval-stack))
;      (if (is? list ilist)
;	  (let ((seq (cast ilist list)))
;	    (dotimes (i (count seq))
;	      (when (traced-call1 pred stack (vector-ref seq i))
;		(return #t)))
;	    #f)
;	  (let ((e (ie-get-enumerator (checked-arg-cast "list" list ienumerable))))
;	    (while (ie-move-next e)
;	      (when (traced-call1 pred stack (ie-current e))
;		(return #t)))
;	    #f))))

  (define-primitive-w/methods (any test-procedure list)
    apply-interface-procedure
    "True if test-procedure returns true for some element of list."
    (define (call2 this test-procedure list)
      (let ((pred (checked-arg-cast "test-procedure" test-procedure procedure))
	    (stack current-thread-eval-stack))
	(if (is? list ilist)
	    (let ((seq (cast ilist list)))
	      (dotimes (i (count seq))
		(let ((tr (checked-test-cast "Result of a test must be a Boolean (i.e. true or false)"
					(traced-call1 pred stack (vector-ref seq i)))))
		(when tr
		  (return #t))))
	      #f)
	    (let ((e (ie-get-enumerator (checked-arg-cast "list" list ienumerable))))
	      (while (ie-move-next e)
		(let ((tr2 (checked-test-cast "Result of a test must be a Boolean (i.e. true or false)"
					      (traced-call1 pred stack (ie-current e)))))
		(when tr2
		  (return #t))))
	      #f))))
    (define (call3 this test-arg list1-arg list2-arg)
      (let ((test (checked-arg-cast "test" test-arg procedure))
	    (list1 (checked-arg-cast "list1" list1-arg ilist))
	    (list2 (checked-arg-cast "list2" list2-arg ilist))
	    (stack current-thread-eval-stack))
	(let ((len (count list1)))
	  (unless (= (count list2)
		     len)
	    (throw (mismatched-list-argument-exception "List arguments must have the same length")))
	  (dotimes (i len)
	    (let ((test-result (checked-test-cast "Result of a test must be a Boolean (true or false)"
						  (traced-call2 test stack
								(vector-ref list1 i)
								(vector-ref list2 i)))))
	      (when test-result
		(return #t))))
	  #f)))
    (define (apply this proc-and-lists)
      (unless (> (length proc-and-lists)
		 1)
	(wrong-number-of-args this proc-and-lists))
      (let ((procarg (vector-ref proc-and-lists 0)))
	(let ((callable (checked-arg-cast "procedure" procarg procedure))
	      (len (- (length proc-and-lists) 1))
	      (stack current-thread-eval-stack))
	  ;; Make sure all args are lists.
	  (let ((seqs (new-array ilist len)))
	    (dotimes (i len)
	      (let ((listarg (vector-ref proc-and-lists (+ i 1))))
		(set (vector-ref seqs i)
		     (checked-arg-cast "list" listarg ilist))))
	    (let ((llen (count (vector-ref seqs 0))))
	      (for ((lindex 1 (+ lindex 1)))
		   (< lindex len)
		   (unless (= (count (vector-ref seqs lindex))
			    llen)
		     (throw (mismatched-list-argument-exception "List arguments must have the same length"))))
	      (dotimes (relt llen)
		(let ((args (new-array object len)))
		  (dotimes (arg len)
		    (set (vector-ref args arg)
			 (vector-ref (vector-ref seqs arg)
				     relt)))
		  (let ((test-result (checked-test-cast "Result of test must be a Boolean (i.e. true or false)"
							(traced-apply callable stack args))))
		    (when test-result
		      (return #t)))))
	      #f))))))

  (define-primitive-w/methods (every test-procedure list)
    apply-interface-procedure
    "True if test-procedure returns true for every element of list."
    (define (call2 this test-procedure list)
      (let ((pred (checked-arg-cast "test-procedure" test-procedure procedure))
	    (stack current-thread-eval-stack))
	(if (is? list ilist)
	    (let ((seq (cast ilist list)))
	      (dotimes (i (count seq))
		(let ((tr (checked-test-cast "Result of a test must be a Boolean (i.e. true or false)"
					     (traced-call1 pred stack (vector-ref seq i)))))
		(unless tr
		  (return #f))))
	      #t)
	    (let ((e (ie-get-enumerator (checked-arg-cast "list" list ienumerable))))
	      (while (ie-move-next e)
		(let ((tr2 (checked-test-cast "Result of a test must be a Boolean (i.e. true or false)"
					      (traced-call1 pred stack (ie-current e)))))
		(unless tr2
		  (return #f))))
	      #t))))
    (define (call3 this test-arg list1-arg list2-arg)
      (let ((test (checked-arg-cast "test" test-arg procedure))
	    (list1 (checked-arg-cast "list1" list1-arg ilist))
	    (list2 (checked-arg-cast "list2" list2-arg ilist))
	    (stack current-thread-eval-stack))
	(let ((len (count list1)))
	  (unless (= (count list2)
		     len)
	    (throw (mismatched-list-argument-exception "List arguments must have the same length")))
	  (dotimes (i len)
	    (let ((test-result (checked-test-cast "Result of a test must be a Boolean (true or false)"
						  (traced-call2 test stack
								(vector-ref list1 i)
								(vector-ref list2 i)))))
	      (unless test-result
		(return #f))))
	  #t)))
    (define (apply this proc-and-lists)
      (unless (> (length proc-and-lists)
		 1)
	(wrong-number-of-args this proc-and-lists))
      (let ((procarg (vector-ref proc-and-lists 0)))
	(let ((callable (checked-arg-cast "procedure" procarg procedure))
	      (len (- (length proc-and-lists) 1))
	      (stack current-thread-eval-stack))
	  ;; Make sure all args are lists.
	  (let ((seqs (new-array ilist len)))
	    (dotimes (i len)
	      (let ((listarg (vector-ref proc-and-lists (+ i 1))))
		(set (vector-ref seqs i)
		     (checked-arg-cast "list" listarg ilist))))
	    (let ((llen (count (vector-ref seqs 0))))
	      (for ((lindex 1 (+ lindex 1)))
		   (< lindex len)
		   (unless (= (count (vector-ref seqs lindex))
			    llen)
		     (throw (mismatched-list-argument-exception "List arguments must have the same length"))))
	      (dotimes (relt llen)
		(let ((args (new-array object len)))
		  (dotimes (arg len)
		    (set (vector-ref args arg)
			 (vector-ref (vector-ref seqs arg)
				     relt)))
		  (let ((test-result (checked-test-cast "Result of test must be a Boolean (i.e. true or false)"
							(traced-apply callable stack args))))
		    (unless test-result
		      (return #f)))))
	      #t))))))

  (define-primitive-procedure (assoc item list)
    "Return the first element of list that is itself a list beginning with item, else null."
    (let ((seq (checked-arg-cast "list" list ilist)))
      (dotimes (i (count seq))
	(let ((elt (as (vector-ref seq i) ilist)))
	  (if (and (not (null? elt))
		   (> (count elt) 0)
		   (tree-equivalent? (vector-ref elt 0)
				     item))
	      (return elt))))
      null))

  (define-primitive-procedure (assq item list)
    "Return the first element of list that is itself a list beginning with item, else null."
    (let ((seq (checked-arg-cast "list" list ilist)))
      (dotimes (i (count seq))
	(let ((elt (as (vector-ref seq i) ilist)))
	  (if (and (not (null? elt))
		   (> (count elt) 0)
		   (eq? (vector-ref elt 0)
				     item))
	      (return elt))))
      null))

  (define-primitive-procedure (assv item list)
    "Return the first element of list that is itself a list beginning with item, else null."
    (let ((seq (checked-arg-cast "list" list ilist)))
      (dotimes (i (count seq))
	(let ((elt (as (vector-ref seq i) ilist)))
	  (if (and (not (null? elt))
		   (> (count elt) 0)
		   (equivalent? (vector-ref elt 0)
				item))
	      (return elt))))
      null))

  (define-primitive-w/methods (contains? item list <compare-predicate>)
    call-interface-procedure
    "True if item appears in list."
    ;; Fast path
    (define (call2 this item list)
      (if (is? list ilist)
	  (let ((seq (cast ilist list)))
	    (>= (%index-of seq item)
		0))
	  (let ((e (ie-get-enumerator (checked-arg-cast "list" list ienumerable))))
	    (while (ie-move-next e)
	      (when (eq? (ie-current e)
			 item)
		(return #t)))
	    #f)))
    (define (call3 this item list predicate)
      (let ((e (ie-get-enumerator (checked-arg-cast "list" list ienumerable)))
	    (pred (checked-arg-cast "compare-predicate" predicate procedure))
	    (stack current-thread-eval-stack))
	(while (ie-move-next e)
	  (let ((test (checked-test-cast "Test procedure must return a Boolean (i.e. true or false)"
					 (traced-call2 pred stack
						       (ie-current e) item))))
	    (when test
	      (return #t))))
	#f)))

  (define-primitive-procedure (count test-procedure list)
    "Returns the number of elements of list that satisfy test-procedure."
    (let ((pred (checked-arg-cast "test-procedure" test-procedure procedure))
	  (stack current-thread-eval-stack)
	  (n 0))
      (if (is? list ilist)
	  (let ((seq (cast ilist list)))
	    (dotimes (i (count seq))
	      (let ((test (checked-test-cast "Test procedure must return a Boolean (i.e. true or false)"
					     (traced-call1 pred stack (vector-ref seq i)))))
		(when test
		  (set n (+ n 1)))))
	    n)
	  (let ((e (ie-get-enumerator (checked-arg-cast "list" list ienumerable))))
	    (while (ie-move-next e)
	      (let ((test2 (checked-test-cast "Test procedure must return a Boolean (i.e. true or false)"
					      (traced-call1 pred stack (ie-current e)))))
	      (when test2
		(set n (+ n 1)))))
	    n))))

  (define-primitive-procedure (call-one-way . remote-procedure-and-args)
    "Calls remote procedure asynchronously and ignores return value"
    (check-arg-type "remote-procedure" (vector-ref remote-procedure-and-args 0) procedure)
    (let ((p (cast procedure (vector-ref remote-procedure-and-args 0)))
	  (args (new-array object (- (length remote-procedure-and-args) 1))))
      (copy-subarray remote-procedure-and-args 1 args 0 (length args))
      (apply-one-way p args)
      null))

  (define-primitive-w/methods (apply procedure <args> ... list-of-arguments)
    apply-interface-procedure
    "Calls procedure with the specified arguments."

    ;; Fast path; this path won't cons when called with an obarray.
    (define (call2 this proc arguments)
      (check-arg-type "procedure"
		      proc
		      procedure)
      (check-arg-type "list-of-arguments"
		      arguments
		      ilist)
      (traced-apply-no-stack (cast procedure proc) (as-object-array arguments)))

    ;; General case
    (define (apply this argument-list)
      (let ((my-arg-count (length argument-list)))
	(cond ((< my-arg-count 2)
	       (wrong-number-of-args this argument-list))
	      (else
	       (check-arg-type "procedure"
			       (vector-ref argument-list 0)
			       procedure)
	       (check-arg-type "list-of-arguments"
			       (vector-ref argument-list
					   (- my-arg-count 1))
			       ilist)
	       (let ((proc (cast procedure (vector-ref argument-list 0)))
		     (arglist-arg (cast ilist
					(vector-ref argument-list
						    (- my-arg-count 1))))
		     (inline-arg-count (- my-arg-count 2)))
		 (let ((target-arglist (new-array object
						  (+ (count arglist-arg)
						     inline-arg-count))))
		   (copy-subarray argument-list
				  1
				  target-arglist
				  0
				  inline-arg-count)
		   (copy-to arglist-arg target-arglist inline-arg-count)
		   (traced-apply-no-stack proc target-arglist))))))))

  (import (setter procedure)
	  "Returns the setter procedure for the specified procedure")

  (define-primitive-procedure (set-setter (procedure proc) (procedure new-setter))
    "Makes new-setter be the setter procedure of proc."
    (set (setter proc) new-setter)
    new-setter)
			      
  (define-primitive-procedure (generic-procedure)
    "Returns a new generic procedure with no methods defined on it."
    (generic-procedure null))

  (define-primitive-procedure (curry . proc-and-args)
    "Makes a procedure that calls procedure with its own arguments followed by args"
    (arglist procedure args ...)
    (new left-curried-procedure
	 (vector-ref proc-and-args 0)
	 (drop proc-and-args 1)))

  (define-primitive-procedure (curry-right . proc-and-args)
    "Makes a procedure that calls procedure with args followed by its own arguments"
    (arglist procedure args ...)
    (new right-curried-procedure
	 (vector-ref proc-and-args 0)
	 (drop proc-and-args 1)))

  (define-primitive-procedure (inspect ob)
    "Runs the inspector on object"
    (inspect ob)
    null)

  (define-primitive-procedure (symbol->string (symbol sym))
    "Returns the name of the symbol as a string"
    (pname sym))

  (define-primitive-procedure (string->symbol (string name))
    "Returns a symbol with the specified name"
    (intern name))

  (define-primitive-procedure (stringify string-or-symbol)
    "Returns the symbol's name as a string, or just the string"
    (cond ((is? string-or-symbol string)
	   (return string-or-symbol))
	  ((is? string-or-symbol symbol)
	   (return (pname (cast symbol string-or-symbol))))
	  (else
	   (throw (exception "The argument to stringify must be a string or a symbol")))))

  (define-primitive-procedure (string-length (string str))
    "The number of characters in str."
    (length str))


  (define-primitive-procedure (random-integer low high)
    "Returns a random whole number between low and high"
    (random-integer random-generator
		    (cast integer low)
		    (cast integer high)))

  (define-primitive-procedure (random-float low high)
    "Returns a random number, possible fractional, between low and high"
    (let ((flow (cast float low)))
      (+ (* (random-float random-generator)
	    (- (cast float high)
	       flow))
	 flow)))

  (define-primitive-procedure (shuffle list)
    "Returns list with its elements randomly rearranged"
    (let ((a (cast (array object) list)))
      (let ((len (length a)))
	(let ((output (new-array object len)))
	  ;; Make output be a random permutation of 0..len-1.
	  (dotimes (i len)
	    (set (vector-ref output i) i))
	  (for ((j (- len 1) (- j 1)))
	       (>= j 0)
	       ;; Pick the value for the jth element of the output
	       (let ((r (random-integer random-generator 0 j)))
		 ;; Swap rth and kth elements
		 (let ((temp (vector-ref output j)))
		   (set (vector-ref output j)
			(vector-ref output r))
		   (set (vector-ref output r) temp))))
	  ;; Now copy over the elements of a specified by the indicies in output
	  (dotimes (k len)
	    (set (vector-ref output k)
		 (vector-ref a (vector-ref output k))))
	  output))))

  (define-primitive-w/methods (to-string object <max-length>)
    call-interface-procedure
    "Returns Meta's string representation for object"
    (define (call1 this obj)
      (write-to-string obj))
    (define (call2 this obj max)
      (check-arg-type "max-length" max integer)
      (safe-write-to-string obj (object->integer max))))

  (define-primitive-procedure (print . objects)
    "Prints objects to Interaction Window"
    (dotimes (i (length objects))
      (let ((obj (vector-ref objects i)))
	(if (is? obj string)
	    (raw-write-to-listener (cast string obj))
	    (write-to-listener obj))))
    null)

  (define-primitive-procedure (print-line . objects)
    "Prints objects to Interaction Window followed by a newline"
    (dotimes (i (length objects))
      (let ((obj (vector-ref objects i)))
	(if (is? obj string)
	    (raw-write-to-listener (cast string obj))
	    (write-to-listener obj))))
    (write-newline-to-listener)
    null)

  (define-primitive-procedure (log-event obj)
    "Adds object to the event log"
    (log-event obj)
    obj)

;  (define-primitive-procedure (write object (text-writer output-stream))
;    "Writes Meta's textual representation on object to output-stream"
;    (write output-stream object))

;  (define-primitive-procedure (read object (text-writer output-stream))
;    "Writes Meta's textual representation on object to output-stream"
;    (read output-stream object))


  (define-primitive-procedure (declare-known-member (clr-type t) (string member-name))
    "Declares that member-name is only used in type t within this namespace"
    (declare-known-member t member-name)
    null)
  (define-primitive-procedure (global-declare-known-member (clr-type t) (string member-name))
    "Declares that member-name is only used in type t"
    (global-declare-known-member t member-name)
    null)

  (define-primitive-w/methods (declare-known-type type <exceptions>)
    call-interface-procedure
    "Declares that the memebers defined (not inherited) in this type are uniquely named."
    (define (call1 this type)
      (declare-known-type (checked-arg-cast "type" type clr-type)
			  (cast ilist (new-array object 0)))
      type)
    (define (call1 this type exceptions)
      (declare-known-type (checked-arg-cast "type" type clr-type)
			  (checked-arg-cast "exceptions" exceptions ilist))
      type))

  (define-primitive-w/methods (global-declare-known-type type <exceptions>)
    call-interface-procedure
    "Declares that the memebers defined (not inherited) in this type are uniquely named."
    (define (call1 this type)
      (global-declare-known-type (checked-arg-cast "type" type clr-type)
				 (cast ilist (new-array object 0)))
      type)
    (define (call1 this type exceptions)
      (global-declare-known-type (checked-arg-cast "type" type clr-type)
				 (checked-arg-cast "exceptions" exceptions ilist))
      type))

  ;;;
  ;;; STUFF THAT CONTROLS THE EVALUATION PROCESS
  ;;;

  (define-primitive-w/methods (eval expression <namespace>)
    call-interface-procedure
    "Run the code represented by the list"
    (define (call1 this expression)
      (eval (simple-parse expression)
	    null
	    current-thread-eval-stack))
    (define (call2 this expression pack)
      (let ((ns (checked-arg-cast "namespace" pack namespace)))
	(eval (parse ns expression ns)
	      null
	      current-thread-eval-stack))))

  (define-primitive-procedure (parse s-expression)
    "Transform the s-expression (i.e. list) into the Expression object that it represents."
    (simple-parse s-expression))

  (define-primitive-procedure (breakpoint . trace-values)
    "Temporarily stops the program and enters the debugger."
    (break null null)
    null)

  (define-primitive-procedure (arglist (i-arglist proc))
    "Returns the list of argument names of the procedure"
    (arglist-kluge proc))

  (define-primitive-procedure (trace . procedures)
    "Activates call tracing of procedures"
    (dotimes (i (length procedures))
      (let ((p (vector-ref procedures i)))
	(set-trace (checked-arg-cast "procedure"
				     p
				     procedure))))
    (if (> (length procedures) 0)
	(vector-ref procedures 0)
	null))

  (define-primitive-procedure (untrace . procedures)
    "Deactivates call tracing of procedures (or all procedures, if not argument give)"
    (cond ((= (length procedures)
	      0)
	   (clear-all-traces))
	  (else
	   (dotimes (i (length procedures))
	     (let ((p (vector-ref procedures i)))
	       (clear-trace (checked-arg-cast "procedure"
					      p
					      procedure))))))
    null)

  (import (lock (object o)
		(procedure thunk))
	  "Runs thunk with object locked")
  (import (unwind-protect (procedure thunk)
			  (procedure cleanup-thunk))
	  "Runs thunk, guaranteeing that cleanup-thunk will be run, even if an error occurs")
  (import (ignore-errors (procedure thunk))
	  "Runs thunk, returning either its value or the exception object it threw")
  (import (catch (procedure thunk) (clr-type exception-type) (procedure exception-handler))
	  "Runs thunk, trapping any exceptions of the specified type and passing them to exception-handler")

  (import (with-escape procedure)
	  "Calls procedure with an escape as an argument.  The escape is a procedure that when called, causes control to return to with-escape.")

  (define-primitive-procedure (call-with-values (procedure producer) (procedure consumer))
    "Calls consumer with multiple values created by producer"
    (let ((stack current-thread-eval-stack))
      (let ((vals (traced-call0 producer stack)))
      (if (is? vals values)
	  (traced-apply consumer stack (actual-values (cast values vals)))
	  (traced-call1 consumer stack vals)))))

  (define-primitive-procedure (values . values-to-return)
    "Returns all the specified values to caller"
    (values values-to-return))

  (define-primitive-w/methods (fluid <default-value>)
    call-interface-procedure
    "Returns a procedure that simulates a dynamically bound variable"
    (define (call0 this)
      (fluid null))
    (define (call1 this default-value)
      (fluid default-value)))

  (define-primitive-procedure (bind . fluids-and-thunk)
    "Runs thunk with fluids dynamically bound to new values"
    (unless (= (bitwise-and (length fluids-and-thunk)
			    1)
	       1)
      (throw (exception "Bind must be called with an odd number of arguments")))
    (check-arg-type "thunk" (vector-ref fluids-and-thunk
					(- (length fluids-and-thunk)
					   1))
		    procedure)
    (bind fluids-and-thunk
	  (cast procedure
		(vector-ref fluids-and-thunk
			    (- (length fluids-and-thunk)
			       1)))))

  (define-primitive-procedure (check (procedure test) value)
    "Returns value, but issues error if [test value] is false."
    (unless (call1 test value)
      (throw (check-failed test value)))
    value)

  (import (throw (exception exception))
	  "Signals the specified exception/error")

  (import (spawn (procedure thunk))
	  "Runs the procedure thunk in a new thread.")

  (define-primitive-procedure (current-source-file)
    "Returns the path to the source file from which this code is loading, if known, else null."
    current-source-file)

  (define-primitive-procedure (find-source (user-procedure p))
    "Finds the source file for specified procedure"
    (edit-source (source-expression p)
		 true
		 true)
    null)

  ;;;
  ;;; SOUND STUFF.
  ;;; Doesn't really belong here.
  ;;;

  (define-primitive-procedure (procedure->sound (procedure proc) (integer samples))
    "Create a sampled sound give a procedure to compute the samples"
    (let ((result (new-array short samples))
	  (stack current-thread-eval-stack))
      (dotimes (i samples)
	(set (vector-ref result i)
	     (object->int16 (traced-call1 proc stack i))))
      result))

  (define-primitive-w/methods (map-sound procedure sound-or-arg ...)
    call-interface-procedure
    "Constructs a sound by applying procedure to each sample of the args."

    (define (maybe-length (object x)) (private static integer)
      (if (is? x (array short))
	  (length (cast (array short) x))
	  0))
    (define (sample (object x) (integer i)) (private static object)
      (if (is? x (array short))
	  (vector-ref (cast (array short) x) i)
	  x))

    (define (call2 this proc-arg sound-arg)
      (let ((proc (checked-arg-cast "procedure" proc-arg procedure))
	    (sound (checked-arg-cast "sound" sound-arg (array short)))
	    (stack current-thread-eval-stack))
	(let ((len (length sound)))
	  (let ((result (new-array short len)))
	    (dotimes (i len)
	      (set (vector-ref result i)
		   (object->int16 (traced-call1 proc stack (vector-ref sound i)))))
	    result))))

    (define (call3 this proc-arg sound1-arg sound2-arg)
      (let ((proc (checked-arg-cast "procedure" proc-arg procedure))
	    (len (max (maybe-length sound1-arg)
		      (maybe-length sound2-arg)))
	    (stack current-thread-eval-stack))
	(let ((result (new-array short len)))
	  (dotimes (i len)
	    (set (vector-ref result i)
		 (object->int16 (traced-call2 proc stack
					      (sample sound1-arg i)
					      (sample sound2-arg i)))))
	  result)))
    (define (call4 this proc-arg sound1-arg sound2-arg sound3-arg)
      (let ((proc (checked-arg-cast "procedure" proc-arg procedure))
	    (len (max (maybe-length sound1-arg)
		      (max (maybe-length sound2-arg)
			   (maybe-length sound3-arg))))
	    (stack current-thread-eval-stack))
	(let ((result (new-array short len)))
	  (dotimes (i len)
	    (set (vector-ref result i)
		 (object->int16 (traced-call3 proc stack
					      (sample sound1-arg i)
					      (sample sound2-arg i)
					      (sample sound3-arg i)))))
	  result)))
    (define (call5 this proc-arg sound1-arg sound2-arg sound3-arg sound4-arg)
      (let ((proc (checked-arg-cast "procedure" proc-arg procedure))
	    (len (max (max (maybe-length sound1-arg)
			   (maybe-length sound2-arg))
		      (max (maybe-length sound3-arg)
			   (maybe-length sound4-arg))))
	    (stack current-thread-eval-stack))
	(let ((result (new-array short len)))
	  (dotimes (i len)
	    (set (vector-ref result i)
		 (object->int16 (traced-call4 proc stack
					      (sample sound1-arg i)
					      (sample sound2-arg i)
					      (sample sound3-arg i)
					      (sample sound4-arg i)))))
	  result)))
    (define (call6 this proc-arg sound1-arg sound2-arg sound3-arg sound4-arg
		   sound5-arg)
      (let ((proc (checked-arg-cast "procedure" proc-arg procedure))
	    (len (max (max (maybe-length sound1-arg)
			   (maybe-length sound2-arg))
		      (max (maybe-length sound3-arg)
			   (max (maybe-length sound4-arg)
				(maybe-length sound5-arg)))))
	    (stack current-thread-eval-stack))
	(let ((result (new-array short len)))
	  (dotimes (i len)
	    (set (vector-ref result i)
		 (object->int16 (traced-call5 proc stack
					      (sample sound1-arg i)
					      (sample sound2-arg i)
					      (sample sound3-arg i)
					      (sample sound4-arg i)
					      (sample sound5-arg i)))))
	  result)))
    (define (call7 this proc-arg sound1-arg sound2-arg sound3-arg sound4-arg
		   sound5-arg sound6-arg)
      (let ((proc (checked-arg-cast "procedure" proc-arg procedure))
	    (len (max (max (max (maybe-length sound1-arg)
				(maybe-length sound2-arg))
			   (max (maybe-length sound3-arg)
				(maybe-length sound4-arg)))
		      (max (maybe-length sound5-arg)
			   (maybe-length sound6-arg))))
	    (stack current-thread-eval-stack))
	(let ((result (new-array short len)))
	  (dotimes (i len)
	    (set (vector-ref result i)
		 (object->int16 (traced-call6 proc stack
					      (sample sound1-arg i)
					      (sample sound2-arg i)
					      (sample sound3-arg i)
					      (sample sound4-arg i)
					      (sample sound5-arg i)
					      (sample sound6-arg i)))))
	  result)))
    (define (call8 this proc-arg sound1-arg sound2-arg sound3-arg sound4-arg
		   sound5-arg sound6-arg sound7-arg)
      (let ((proc (checked-arg-cast "procedure" proc-arg procedure))
	    (len (max (max (max (maybe-length sound1-arg)
				(maybe-length sound2-arg))
			   (max (maybe-length sound3-arg)
				(maybe-length sound4-arg)))
		      (max (max (maybe-length sound5-arg)
				(maybe-length sound6-arg))
			   (maybe-length sound7-arg))))
	    (stack current-thread-eval-stack))
	(let ((result (new-array short len)))
	  (dotimes (i len)
	    (set (vector-ref result i)
		 (object->int16 (traced-call7 proc stack
					      (sample sound1-arg i)
					      (sample sound2-arg i)
					      (sample sound3-arg i)
					      (sample sound4-arg i)
					      (sample sound5-arg i)
					      (sample sound6-arg i)
					      (sample sound7-arg i)))))
	  result)))
    (define (call9 this proc-arg sound1-arg sound2-arg sound3-arg sound4-arg
		   sound5-arg sound6-arg sound7-arg sound8-arg)
      (let ((proc (checked-arg-cast "procedure" proc-arg procedure))
	    (len (max (max (max (maybe-length sound1-arg)
				(maybe-length sound2-arg))
			   (max (maybe-length sound3-arg)
				(maybe-length sound4-arg)))
		      (max (max (maybe-length sound5-arg)
				(maybe-length sound6-arg))
			   (max (maybe-length sound7-arg)
				(maybe-length sound8-arg)))))
	    (stack current-thread-eval-stack))
	(let ((result (new-array short len)))
	  (dotimes (i len)
	    (set (vector-ref result i)
		 (object->int16 (traced-call8 proc stack
					      (sample sound1-arg i)
					      (sample sound2-arg i)
					      (sample sound3-arg i)
					      (sample sound4-arg i)
					      (sample sound5-arg i)
					      (sample sound6-arg i)
					      (sample sound7-arg i)
					      (sample sound8-arg i)))))
	  result)))
    (define (call10 this proc-arg sound1-arg sound2-arg sound3-arg sound4-arg
		   sound5-arg sound6-arg sound7-arg sound8-arg sound9-arg)
      (let ((proc (checked-arg-cast "procedure" proc-arg procedure))
	    (len (max (max (max (max (maybe-length sound1-arg)
				     (maybe-length sound2-arg))
				(max (maybe-length sound3-arg)
				     (maybe-length sound4-arg)))
			   (max (max (maybe-length sound5-arg)
				     (maybe-length sound6-arg))
				(max (maybe-length sound7-arg)
				     (maybe-length sound8-arg))))
		      (maybe-length sound9-arg)))
	    (stack current-thread-eval-stack))
	(let ((result (new-array short len)))
	  (dotimes (i len)
	    (set (vector-ref result i)
		 (object->int16 (traced-call9 proc stack
					      (sample sound1-arg i)
					      (sample sound2-arg i)
					      (sample sound3-arg i)
					      (sample sound4-arg i)
					      (sample sound5-arg i)
					      (sample sound6-arg i)
					      (sample sound7-arg i)
					      (sample sound8-arg i)
					      (sample sound9-arg i)))))
	  result)))
    (define (call11 this proc-arg sound1-arg sound2-arg sound3-arg sound4-arg
		   sound5-arg sound6-arg sound7-arg sound8-arg sound9-arg
		   sound10-arg)
      (let ((proc (checked-arg-cast "procedure" proc-arg procedure))
	    (len (max (max (max (max (maybe-length sound1-arg)
				     (maybe-length sound2-arg))
				(max (maybe-length sound3-arg)
				     (maybe-length sound4-arg)))
			   (max (max (maybe-length sound5-arg)
				     (maybe-length sound6-arg))
				(max (maybe-length sound7-arg)
				     (maybe-length sound8-arg))))
		      (max (maybe-length sound9-arg)
			   (maybe-length sound10-arg))))
	    (stack current-thread-eval-stack))
	(let ((result (new-array short len)))
	  (dotimes (i len)
	    (set (vector-ref result i)
		 (object->int16 (traced-call10 proc stack
					      (sample sound1-arg i)
					      (sample sound2-arg i)
					      (sample sound3-arg i)
					      (sample sound4-arg i)
					      (sample sound5-arg i)
					      (sample sound6-arg i)
					      (sample sound7-arg i)
					      (sample sound8-arg i)
					      (sample sound9-arg i)
					      (sample sound10-arg i)))))
	  result))))

  (define-primitive-procedure (iir-lpf ((array short) sound)
					  (float coefficient))
    "Low-pass filter (first-order, unity-gain infinite-impulse-response)"
    (let ((samples (length sound)))
      (let ((result (new-array short samples))
	    (previous-sample 0.0)
	    (c0 (- 1.0 coefficient)))
	(dotimes (i samples)
	  (set previous-sample
	       (+ (* c0
		     (vector-ref sound i))
		  (* coefficient previous-sample)))
	  (set (vector-ref result i)
	       (cast short previous-sample)))
	result)))

  (define-primitive-procedure (reverb ((array short) sound)
				      (integer delay)
				      (float gain))
    "Adds reverb to sound with the specified delay (in samples) and gain."
    (let ((samples (length sound)))
      (let ((result (new-array short samples)))
	(copy-subarray sound 0 result 0 delay)
	(for ((i delay (+ i 1)))
	     (< i samples)
	  (set (vector-ref result i)
	       (cast short
		     (+ (vector-ref sound i)
			(* gain
			   (vector-ref result (- i delay)))))))
	result)))

  ;;;
  ;;; MISC TYPE PREDICATES
  ;;;

  (define-primitive-procedure (null? x)
    "True if x is the null object"
    (eq? x null))

  (define-primitive-procedure (non-null? x)
    "True if x isn't the null object"
    (not (eq? x null)))

  (define-primitive-procedure (integer? x)
    "True if x is an integer"
    (integer? x))
  (define-primitive-procedure (floating-point? x)
    "True if x is a floating-point number"
    (or (is? x float)
	(is? x single-float)))
  (import (number? (object x))
	  "True if x is a number")

  (define-primitive-procedure (string? x)
    "True if x is a string"
    (is? x string))
  (define-primitive-procedure (list? x)
    "True if x is a list"
    (is? x ilist))
  (define-primitive-procedure (symbol? x)
    "True if x is a symbol"
    (is? x symbol))
  (define-primitive-procedure (keyword? x)
    "True if x is a keyword"
    (is? x keyword))

  (define-primitive-procedure (procedure? x)
    "True if x is a procedure"
    (is? x procedure))

  (define-primitive-procedure (generic-procedure? x)
    "True if x is a generic procedure"
    (is? x generic-procedure))

  (define-primitive-procedure (boolean? x)
    "True if x is a Boolean (true or false)"
    (is? x boolean))
  (define-primitive-procedure (character? x)
    "True if x is a character"
    (is? x character))

  ;;; Macro stuff
  (define-primitive-procedure (macro (procedure rewriter))
    (macro rewriter))

  (define-primitive-procedure (local-variable (symbol name))
    "Creates a local variable for use inside a macro"
    (local-variable name (type->clr-type object) null 0 0))

  (define-primitive-procedure (syntax-error (string message)
					    (object offending-expression))
    (throw (syntax-error message offending-expression))))

;;; Copied over from New2D/graphic-objects.scm because it's common
;;; to 2D and 3D

(define-imported-class (color "System.Drawing.Color") object
  (define red "R" (public) integer)
  (define green "G" (public) integer)
  (define blue "B" (public) integer)
  (define alpha "A" (public) integer))

(define-imported-class (rectangle-f "System.Drawing.RectangleF"
				    (single-float x)
				    (single-float y)
				    (single-float width)
				    (single-float height))
  object
  (define rectangle-x "X" (public) single-float)
  (define rectangle-y "Y" (public) single-float)
  (define rectangle-top "Top" (public) single-float)
  (define rectangle-bottom "Bottom" (public) single-float)
  (define rectangle-right "Right" (public) single-float)
  (define rectangle-left "Left" (public) single-float)
  (define rectangle-width "Width" (public) single-float)
  (define rectangle-height "Height" (public) single-float))

(import (rectangle-f-union "RectangleF.Union"
			   (proc ((type-expression-value 'rectangle-f)
				  (type-expression-value 'rectangle-f))
				 (type-expression-value 'rectangle-f))))

(define-imported-class (rectangle "System.Drawing.Rectangle"
				    (integer x)
				    (integer y)
				    (integer width)
				    (integer height))
  rectangle-f)
;  (define rectangle-x "X" (public) single-float)
;  (define rectangle-y "Y" (public) single-float)
;  (define rectangle-width "Width" (public) single-float)
; (define rectangle-height "Height" (public) single-float))

(define-imported-class (point-f "System.Drawing.PointF"
				(single-float x) (single-float y))
  object
  (define point-f-x "X" (public) single-float)
  (define point-f-y "Y" (public) single-float))

(define-imported-class (point "System.Drawing.Point"
				(integer x) (integer y))
  object
  (define point-x "X" (public) integer)
  (define point-y "Y" (public) integer))

; Silly stubs
(define-imported-class int-ptr object)
(define-imported-class (graphics-container "System.Drawing.Drawing2D.GraphicsContainer")
  object)
(define-imported-class (graphics-unit "System.Drawing.GraphicsUnit")
  object)

(define-imported-class (size-f "System.Drawing.SizeF"
			       (single-float width) (single-float height))
  object
  (define size-f-is-empty "IsEmpty" (public) boolean)
  (define size-f-width "Width" (public) single-float)
  (define size-f-height "Height" (public) single-float))

(define-imported-class (size "System.Drawing.Size"
			       (integer width) (integer height))
  object
  (define size-is-empty "IsEmpty" (public) boolean)
  (define size-width "Width" (public) integer)
  (define size-height "Height" (public) integer))

(import (color-from-name "System.Drawing.Color.FromName"
			 (proc (string) (type-expression-value 'color)))
	(color-from-argb "System.Drawing.Color.FromArgb"
			 (proc (integer integer integer integer)
			       (type-expression-value 'color))))

(define-imported-class (pen "System.Drawing.Pen"
			    (color c) (single-float width))
  object)

(define-imported-class (font "System.Drawing.Font")
  object)
(define-imported-class (brush "System.Drawing.Brush")
  object)

(define-imported-class (solid-brush "System.Drawing.SolidBrush"
				    (color c))
  brush)

(define-imported-class (linear-gradient-brush "System.Drawing.Drawing2D.LinearGradientBrush"
					      (rectangle-f bounds)
					      (color start)
					      (color end)
					      (single-float orientation))
  brush)

(define-imported-class image object
  (define size "Size" (public) size)
  (define image-width "Width" (public) integer)
  (define image-height "Height" (public) integer))

(define-imported-class (memory-stream "System.IO.MemoryStream") object
  (define (close) (public) void))

(define-imported-class (metafile "System.Drawing.Imaging.Metafile"
				 (memory-stream stream)
				 (int-ptr hdc))
  image)

(%import-object 'render-high-quality "System.Drawing.Drawing2D.SmoothingMode.HighQuality" integer-type)
(%import-object 'render-antialiased "System.Drawing.Drawing2D.SmoothingMode.AntiAlias" integer-type)

(define-imported-class (region (rectangle-f r)) objecT)
(define-imported-class (graphics "System.Drawing.Graphics")
  object
  (define page-unit "PageUnit" (public) graphics-unit)

  (define clip "Clip" (public) region)

  (define (clear (color c)) (public) void)

  (define (draw-arc (pen p)
		    (rectangle-f rect)
		    (single-float start)
		    (single-float end))
    (public) void)
  (define (draw-ellipse (pen p)
			(rectangle-f r))
    (public) void)
  (define (draw-image (image i)
		      (point-f p))
    (public) void)
  (define (draw-line (pen p)
		     (point-f start)
		     (point-f end))
    (public) void)
  (define (draw-lines (pen p)
		      ((array point-f) points))
    (public) void)
  (define (draw-polygon (pen p)
			((array point-f) points))
    (public) void)
  (define (draw-rectangle (pen p)
			  (rectangle-f r))
    (public) void)
  (define (draw-string (string s)
		       (font t)
		       (brush b)
		       (point-f p))
    (public) void)

  (define (draw-image (image i)
		      (rectangle-f r))
    (public) void)

  (define (fill-ellipse (brush b)
			(rectangle-f r))
    (public) void)
  (define (fill-rectangle (brush b) (rectangle-f r)) (public) void)

  (define (flush) (public) void)

  (define (measure-string (string s) (font f))
    (public) size-f)
  
  (define (begin-container) (public) graphics-container)
  (define (end-container (graphics-container c))
    (public) void)

  (define (rotate-transform (single-float angle))
    (public) void)
  (define (translate-transform (single-float x) (single-float y))
    (public) void)
  (define (scale-transform (single-float width-factor)
			   (single-float height-factor))
    (public) void)
  (define smoothing-mode "SmoothingMode" (public) integer)

  (define (get-hdc) (public) int-ptr)
  (define (release-hdc (int-ptr hdc)) (public) void))

(import (graphics-from-image "System.Drawing.Graphics.FromImage"
			     (proc ((type-expression-value 'image)) 
				   (type-expression-value 'graphics))))

(import (make-bitmap "new Bitmap"
		     (proc (integer integer)
			   (type-expression-value 'bitmap))))

(import-methods (dispose "Dispose" (proc (object) void)))

(import (object->single-float "System.Convert.ToSingle" (proc (object) single-float))
	(object->point-f "PointFVectorSpace.ToPointF"
			 (proc (object string)
			       (type-expression-value 'point-f))))

(import (vector3? "VectorSpace.Is3Vector"
		  (proc (object) boolean))
	(make-3vector "VectorSpace.Make3Vector"
		      (proc (single-float single-float single-float) object))
	(vector3-x "VectorSpace.Vector3Accessors[0]"
		   (proc (object) single-float))
	(vector3-y "VectorSpace.Vector3Accessors[1]"
		   (proc (object) single-float))
	(vector3-z "VectorSpace.Vector3Accessors[2]"
		   (proc (object) single-float))
	(vector4? "VectorSpace.Is4Vector"
		  (proc (object) boolean))
	(make-4vector "VectorSpace.Make4Vector"
		      (proc (single-float single-float single-float
					  single-float)
			    object))
	(vector4-x "VectorSpace.Vector4Accessors[0]"
		   (proc (object) single-float))
	(vector4-y "VectorSpace.Vector4Accessors[1]"
		   (proc (object) single-float))
	(vector4-z "VectorSpace.Vector4Accessors[2]"
		   (proc (object) single-float))
	(vector4-w "VectorSpace.Vector4Accessors[3]"
		   (proc (object) single-float)))

(define-initialized-module (lisp common-graphics)
  ;;;
  ;;; POINTS ETC
  ;;;
  (define-primitive-w/methods (vector x y <optional-z> <optional-w>) call-interface-procedure
    "Creates a new 2D, 3D, or 4D vector"
    (define (call2 p x y)
      (check-arg-type "x" x float)
      (check-arg-type "y" y float)
      (if (and (integer? x)
	       (integer? y))
	  (new point
	       (object->integer x)
	       (object->integer y))
	  (new point-f
	       (object->single-float x)
	       (object->single-float y))))
    (define (call3 p x y z)
      (check-arg-type "x" x float)
      (check-arg-type "y" y float)
      (check-arg-type "z" z float)
      (make-3vector (object->single-float x)
		    (object->single-float y)
		    (object->single-float z)))
    (define (call4 p x y z w)
      (check-arg-type "x" x float)
      (check-arg-type "y" y float)
      (check-arg-type "z" z float)
      (check-arg-type "w" z float)
      (make-4vector (object->single-float x)
		    (object->single-float y)
		    (object->single-float z)
		    (object->single-float w))))

  (define-primitive-procedure (vector2? x)
    "True if x is a 2D vector"
    (or (is? x point)
	(is? x point-f)))

  (define-primitive-procedure (vector3? x)
    "True if x is a 3D vector"
    (vector3? x))

  (define-primitive-procedure (vector4? x)
    "True if x is a 4D vector"
    (vector4? x))

  (define-primitive-procedure (vector? x)
    "True if x is a 2D vector"
    (or (is? x point)
	(is? x point-f)
	(vector3? x)
	(vector4? x)))

  (define-primitive-procedure (vector-x v)
    "Returns the X coordinate of the specified vector"
    (cond ((is? v point-f)
	   (point-f-x (cast point-f v)))
	  ((is? v point)
	   (point-x (cast point v)))
	  ((vector3? v)
	   (vector3-x v))
	  ((vector4? v)
	   (vector4-x v))
	  (else
	   (throw (new exception "Argument is not a vector")))))

  (define-primitive-procedure (vector-y v)
    "Returns the Y coordinate of the specified point/vector"
    (cond ((is? v point-f)
	   (point-f-y (cast point-f v)))
	  ((is? v point)
	   (point-y (cast point v)))
	  ((vector3? v)
	   (vector3-y v))
	  ((vector4? v)
	   (vector4-y v))
	  (else
	   (throw (new exception "Argument is not a vector")))))

  (define-primitive-procedure (vector-z v)
    "Returns the Z coordinate of the specified 3- or 4D vector"
    (cond ((vector3? v)
	   (vector3-z v))
	  ((vector4? v)
	   (vector4-z v))
	  ((or (is? v point-f)
	       (is? v point))
	   (throw (new exception "Vector is only 2D")))
	  (else
	   (throw (new exception "Argument is not a vector")))))

  (define-primitive-procedure (vector-w v)
    "Returns the Z coordinate of the specified 3- or 4D vector"
    (cond ((vector4? v)
	   (vector4-w v))
	  ((vector3? v)
	   (throw (new exception "Vector is only 3D; a 4D vector is needed.")))
	  ((or (is? v point-f)
	       (is? v point))
	   (throw (new exception "Vector is only 2D")))
	  (else
	   (throw (new exception "Argument is not a vector")))))

  (define-primitive-procedure (rectangle-top r)
    "Returns the Y coordinate of the top of the rectangle"
    (cond ((is? r rectangle-f)
	   (rectangle-top (cast rectangle-f r)))
	  ((is? r rectangle)
	   (rectangle-top (cast rectangle r)))
	  (else
	   (throw (new exception "Argument is not a Rectangle or RectangleF")))))

  (define-primitive-procedure (rectangle-bottom r)
    "Returns the Y coordinate of the bottom of the rectangle"
    (cond ((is? r rectangle-f)
	   (rectangle-bottom (cast rectangle-f r)))
	  ((is? r rectangle)
	   (rectangle-bottom (cast rectangle r)))
	  (else
	   (throw (new exception "Argument is not a Rectangle or RectangleF")))))

  (define-primitive-procedure (rectangle-left r)
    "Returns the X coordinate of the left-hand side of the rectangle"
    (cond ((is? r rectangle-f)
	   (rectangle-left (cast rectangle-f r)))
	  ((is? r rectangle)
	   (rectangle-left (cast rectangle r)))
	  (else
	   (throw (new exception "Argument is not a Rectangle or RectangleF")))))

  (define-primitive-procedure (rectangle-right r)
    "Returns the X coordinate of the right-hand side of the rectangle"
    (cond ((is? r rectangle-f)
	   (rectangle-right (cast rectangle-f r)))
	  ((is? r rectangle)
	   (rectangle-right (cast rectangle r)))
	  (else
	   (throw (new exception "Argument is not a Rectangle or RectangleF")))))

  (define-primitive-procedure (rectangle-width r)
    "Returns the width of the rectangle"
    (cond ((is? r rectangle-f)
	   (rectangle-width (cast rectangle-f r)))
	  ((is? r rectangle)
	   (rectangle-width (cast rectangle r)))
	  (else
	   (throw (new exception "Argument is not a Rectangle or RectangleF")))))

  (define-primitive-procedure (rectangle-height r)
    "Returns the height of the rectangle"
    (cond ((is? r rectangle-f)
	   (rectangle-height (cast rectangle-f r)))
	  ((is? r rectangle)
	   (rectangle-height (cast rectangle r)))
	  (else
	   (throw (new exception "Argument is not a Rectangle or RectangleF")))))

  ;;;
  ;;; COLORS
  ;;;
  (define-primitive-w/methods (color red green blue <alpha>)
    call-interface-procedure
    "Returns the color with the specified name, RGB values, or RGBA values."
    (define (call1 this name)
      (let ((sname (as name string)))
	(if (null? sname)
	    (let ((symname (as name symbol)))
	      (if (null? symname)
		  (throw (exception "Color name is not a string or symbol"))
		  (color-from-name (pname symname))))
	    (color-from-name sname))))
    (define (call3 this red green blue)
      (color-from-argb 255
		       (max 0 (min 255 (object->integer red)))
		       (max 0 (min 255 (object->integer green)))
		       (max 0 (min 255 (object->integer blue)))))
    (define (call3 this red green blue alpha)
      (color-from-argb (max 0 (min 255 (object->integer alpha)))
		       (max 0 (min 255 (object->integer red)))
		       (max 0 (min 255 (object->integer green)))
		       (max 0 (min 255 (object->integer blue))))))

  (import (red color)
	  "Returns the amount of red light in the color as a number from 0 to 255")
  (import (green color)
	  "Returns the amount of red light in the color as a number from 0 to 255")
  (import (blue color)
	  "Returns the amount of red light in the color as a number from 0 to 255")
  (import (alpha color)
	  "Returns the amount of transparency of the color as a number from 0 to 255")

  (define-primitive-procedure (intensity (color color))
    (/ (+ (red color)
	  (blue color)
	  (green color))
       3.0))

  (define-primitive-procedure (gray (float intensity))
    (let ((i (max 0 (min 255 (cast integer intensity)))))
      (color-from-argb 255 i i i)))

  ;;;
  ;;; BRUSHES
  ;;;

  (define-primitive-procedure (gradient-brush (rectangle-f rectangle)
					      (color start-color)
					      (color end-color)
					      (float direction))
    (linear-gradient-brush rectangle
			   start-color
			   end-color
			   (cast single-float direction)))

  ;;;
  ;;; PENS
  ;;;

  (define-primitive-procedure (pen pen-color (float width))
    "Creates a new pen object with the specified color and width"
    (let ((the-color (cond ((is? pen-color symbol)
			    (color-from-name (pname (cast symbol pen-color))))
			   ((is? pen-color string)
			    (color-from-name (cast string pen-color)))
			   (else
			    (cast color pen-color)))))
      (pen the-color width)))



  (define-primitive-procedure (pixel (bitmap bitmap) (integer column) (integer row))
    "Returns the pixel color at the specified row and column of the bitmap."
    (get-pixel bitmap column row))

  ;;;
  ;;; MISC TYPE PREDICATES
  ;;;

  (define-primitive-procedure (bitmap? x)
    "True if x is bitmap"
    (is? x bitmap))
  (define-primitive-procedure (color? x)
    "True if x is a color object"
    (is? x color))

  (define-primitive-procedure (font? x)
    "True if x is a font object"
    (is? x font))

  (define-primitive-procedure (pen? x)
    "True if x is a pen object"
    (is? x pen))
  (define-primitive-procedure (brush? x)
    "True if x is a brush object"
    (is? x brush))

  (define-primitive-procedure (rectangle? x)
    "True if x is a rectangle object"
    (or (is? x rectangle)
	(is? x rectangle-f)))
  )